home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / classes.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  157.5 KB  |  6,319 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Classes;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses SysUtils, Windows;
  17.  
  18. const
  19.  
  20. { Maximum TList size }
  21.  
  22.   MaxListSize = Maxint div 16;
  23.  
  24. { TStream seek origins }
  25.  
  26.   soFromBeginning = 0;
  27.   soFromCurrent = 1;
  28.   soFromEnd = 2;
  29.  
  30. { TFileStream create mode }
  31.  
  32.   fmCreate = $FFFF;
  33.  
  34. { TParser special tokens }
  35.  
  36.   toEOF     = Char(0);
  37.   toSymbol  = Char(1);
  38.   toString  = Char(2);
  39.   toInteger = Char(3);
  40.   toFloat   = Char(4);
  41.  
  42. type
  43.  
  44. { Text alignment types }
  45.  
  46.   TAlignment = (taLeftJustify, taRightJustify, taCenter);
  47.   TLeftRight = taLeftJustify..taRightJustify;
  48.  
  49. { Types used by standard events }
  50.  
  51.   TShiftState = set of (ssShift, ssAlt, ssCtrl,
  52.     ssLeft, ssRight, ssMiddle, ssDouble);
  53.  
  54.   THelpContext = -MaxLongint..MaxLongint;
  55.  
  56. { Standard events }
  57.  
  58.   TNotifyEvent = procedure(Sender: TObject) of object;
  59.   THelpEvent = function (Command: Word; Data: Longint;
  60.     var CallHelp: Boolean): Boolean of object;
  61.   TGetStrProc = procedure(const S: string) of object;
  62.  
  63. { Exception classes }
  64.  
  65.   EStreamError = class(Exception);
  66.   EFCreateError = class(EStreamError);
  67.   EFOpenError = class(EStreamError);
  68.   EFilerError = class(EStreamError);
  69.   EReadError = class(EFilerError);
  70.   EWriteError = class(EFilerError);
  71.   EClassNotFound = class(EFilerError);
  72.   EMethodNotFound = class(EFilerError);
  73.   EInvalidImage = class(EFilerError);
  74.   EResNotFound = class(Exception);
  75.   EListError = class(Exception);
  76.   EBitsError = class(Exception);
  77.   EStringListError = class(Exception);
  78.   EComponentError = class(Exception);
  79.   EParserError = class(Exception);
  80.   EOutOfResources = class(EOutOfMemory);
  81.   EInvalidOperation = class(Exception);
  82.  
  83. { Forward class declarations }
  84.  
  85.   TStream = class;
  86.   TFiler = class;
  87.   TReader = class;
  88.   TWriter = class;
  89.   TComponent = class;
  90.  
  91. { TList class }
  92.  
  93.   PPointerList = ^TPointerList;
  94.   TPointerList = array[0..MaxListSize - 1] of Pointer;
  95.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  96.  
  97.   TList = class(TObject)
  98.   private
  99.     FList: PPointerList;
  100.     FCount: Integer;
  101.     FCapacity: Integer;
  102.   protected
  103.     function Get(Index: Integer): Pointer;
  104.     procedure Grow; virtual;
  105.     procedure Put(Index: Integer; Item: Pointer);
  106.     procedure SetCapacity(NewCapacity: Integer);
  107.     procedure SetCount(NewCount: Integer);
  108.   public
  109.     destructor Destroy; override;
  110.     function Add(Item: Pointer): Integer;
  111.     procedure Clear;
  112.     procedure Delete(Index: Integer);
  113.     class procedure Error(const Msg: string; Data: Integer); virtual;
  114.     procedure Exchange(Index1, Index2: Integer);
  115.     function Expand: TList;
  116.     function First: Pointer;
  117.     function IndexOf(Item: Pointer): Integer;
  118.     procedure Insert(Index: Integer; Item: Pointer);
  119.     function Last: Pointer;
  120.     procedure Move(CurIndex, NewIndex: Integer);
  121.     function Remove(Item: Pointer): Integer;
  122.     procedure Pack;
  123.     procedure Sort(Compare: TListSortCompare);
  124.     property Capacity: Integer read FCapacity write SetCapacity;
  125.     property Count: Integer read FCount write SetCount;
  126.     property Items[Index: Integer]: Pointer read Get write Put; default;
  127.     property List: PPointerList read FList;
  128.   end;
  129.  
  130. { TThreadList class }
  131.  
  132.   TThreadList = class
  133.   private
  134.     FList: TList;
  135.     FLock: TRTLCriticalSection;
  136.   public
  137.     constructor Create;
  138.     destructor Destroy; override;
  139.     procedure Add(Item: Pointer);
  140.     procedure Clear;
  141.     function  LockList: TList;
  142.     procedure Remove(Item: Pointer);
  143.     procedure UnlockList;
  144.   end;
  145.  
  146. { TBits class }
  147.  
  148.   TBits = class
  149.   private
  150.     FSize: Integer;
  151.     FBits: Pointer;
  152.     procedure Error;
  153.     procedure SetSize(Value: Integer);
  154.     procedure SetBit(Index: Integer; Value: Boolean);
  155.     function GetBit(Index: Integer): Boolean;
  156.   public
  157.     destructor Destroy; override;
  158.     function OpenBit: Integer;
  159.     property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
  160.     property Size: Integer read FSize write SetSize;
  161.   end;
  162.  
  163. { TPersistent abstract class }
  164.  
  165. {$M+}
  166.  
  167.   TPersistent = class(TObject)
  168.   private
  169.     procedure AssignError(Source: TPersistent);
  170.   protected
  171.     procedure AssignTo(Dest: TPersistent); virtual;
  172.     procedure DefineProperties(Filer: TFiler); virtual;
  173.     function  GetOwner: TPersistent; dynamic;
  174.   public
  175.     procedure Assign(Source: TPersistent); virtual;
  176.     function  GetNamePath: string; dynamic;
  177.   end;
  178.  
  179. {$M-}
  180.  
  181. { TPersistent class reference type }
  182.  
  183.   TPersistentClass = class of TPersistent;
  184.  
  185. { TCollection class }
  186.  
  187.   TCollection = class;
  188.  
  189.   TCollectionItem = class(TPersistent)
  190.   private
  191.     FCollection: TCollection;
  192.     FID: Integer;
  193.     function GetIndex: Integer;
  194.     procedure SetCollection(Value: TCollection);
  195.   protected
  196.     procedure Changed(AllItems: Boolean);
  197.     function GetNamePath: string; override;
  198.     function GetOwner: TPersistent; override;
  199.     function GetDisplayName: string; virtual;
  200.     procedure SetIndex(Value: Integer); virtual;
  201.     procedure SetDisplayName(const Value: string); virtual;
  202.   public
  203.     constructor Create(Collection: TCollection); virtual;
  204.     destructor Destroy; override;
  205.     property Collection: TCollection read FCollection write SetCollection;
  206.     property ID: Integer read FID;
  207.     property Index: Integer read GetIndex write SetIndex;
  208.     property DisplayName: string read GetDisplayName write SetDisplayName;
  209.   end;
  210.  
  211.   TCollectionItemClass = class of TCollectionItem;
  212.  
  213.   TCollection = class(TPersistent)
  214.   private
  215.     FItemClass: TCollectionItemClass;
  216.     FItems: TList;
  217.     FUpdateCount: Integer;
  218.     FNextID: Integer;
  219.     FPropName: string;
  220.     function GetCount: Integer;
  221.     function GetPropName: string;
  222.     procedure InsertItem(Item: TCollectionItem);
  223.     procedure RemoveItem(Item: TCollectionItem);
  224.   protected
  225.     { Design-time editor support }
  226.     function GetAttrCount: Integer; dynamic;
  227.     function GetAttr(Index: Integer): string; dynamic;
  228.     function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
  229.     function GetNamePath: string; override;
  230.     procedure Changed;
  231.     function GetItem(Index: Integer): TCollectionItem;
  232.     procedure SetItem(Index: Integer; Value: TCollectionItem);
  233.     procedure SetItemName(Item: TCollectionItem); virtual;
  234.     procedure Update(Item: TCollectionItem); virtual;
  235.     property PropName: string read GetPropName write FPropName;
  236.   public
  237.     constructor Create(ItemClass: TCollectionItemClass);
  238.     destructor Destroy; override;
  239.     function Add: TCollectionItem;
  240.     procedure Assign(Source: TPersistent); override;
  241.     procedure BeginUpdate;
  242.     procedure Clear;
  243.     procedure EndUpdate;
  244.     function FindItemID(ID: Integer): TCollectionItem;
  245.     property Count: Integer read GetCount;
  246.     property ItemClass: TCollectionItemClass read FItemClass;
  247.     property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
  248.   end;
  249.  
  250.   TStrings = class;
  251.  
  252. { IStringsAdapter interface }
  253. { Maintains link between TStrings and IStrings implementations }
  254.  
  255.   IStringsAdapter = interface
  256.     ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}']
  257.     procedure ReferenceStrings(S: TStrings);
  258.     procedure ReleaseStrings;
  259.   end;
  260.  
  261. { TStrings class }
  262.  
  263.   TStrings = class(TPersistent)
  264.   private
  265.     FUpdateCount: Integer;
  266.     FAdapter: IStringsAdapter;
  267.     function GetCommaText: string;
  268.     function GetName(Index: Integer): string;
  269.     function GetValue(const Name: string): string;
  270.     procedure ReadData(Reader: TReader);
  271.     procedure SetCommaText(const Value: string);
  272.     procedure SetStringsAdapter(const Value: IStringsAdapter);
  273.     procedure SetValue(const Name, Value: string);
  274.     procedure WriteData(Writer: TWriter);
  275.   protected
  276.     procedure DefineProperties(Filer: TFiler); override;
  277.     procedure Error(const Msg: string; Data: Integer);
  278.     function Get(Index: Integer): string; virtual; abstract;
  279.     function GetCapacity: Integer; virtual;
  280.     function GetCount: Integer; virtual; abstract;
  281.     function GetObject(Index: Integer): TObject; virtual;
  282.     function GetTextStr: string; virtual;
  283.     procedure Put(Index: Integer; const S: string); virtual;
  284.     procedure PutObject(Index: Integer; AObject: TObject); virtual;
  285.     procedure SetCapacity(NewCapacity: Integer); virtual;
  286.     procedure SetTextStr(const Value: string); virtual;
  287.     procedure SetUpdateState(Updating: Boolean); virtual;
  288.   public
  289.     destructor Destroy; override;
  290.     function Add(const S: string): Integer; virtual;
  291.     function AddObject(const S: string; AObject: TObject): Integer; virtual;
  292.     procedure Append(const S: string);
  293.     procedure AddStrings(Strings: TStrings); virtual;
  294.     procedure Assign(Source: TPersistent); override;
  295.     procedure BeginUpdate;
  296.     procedure Clear; virtual; abstract;
  297.     procedure Delete(Index: Integer); virtual; abstract;
  298.     procedure EndUpdate;
  299.     function Equals(Strings: TStrings): Boolean;
  300.     procedure Exchange(Index1, Index2: Integer); virtual;
  301.     function GetText: PChar; virtual;
  302.     function IndexOf(const S: string): Integer; virtual;
  303.     function IndexOfName(const Name: string): Integer;
  304.     function IndexOfObject(AObject: TObject): Integer;
  305.     procedure Insert(Index: Integer; const S: string); virtual; abstract;
  306.     procedure InsertObject(Index: Integer; const S: string;
  307.       AObject: TObject);
  308.     procedure LoadFromFile(const FileName: string); virtual;
  309.     procedure LoadFromStream(Stream: TStream); virtual;
  310.     procedure Move(CurIndex, NewIndex: Integer); virtual;
  311.     procedure SaveToFile(const FileName: string); virtual;
  312.     procedure SaveToStream(Stream: TStream); virtual;
  313.     procedure SetText(Text: PChar); virtual;
  314.     property Capacity: Integer read GetCapacity write SetCapacity;
  315.     property CommaText: string read GetCommaText write SetCommaText;
  316.     property Count: Integer read GetCount;
  317.     property Names[Index: Integer]: string read GetName;
  318.     property Objects[Index: Integer]: TObject read GetObject write PutObject;
  319.     property Values[const Name: string]: string read GetValue write SetValue;
  320.     property Strings[Index: Integer]: string read Get write Put; default;
  321.     property Text: string read GetTextStr write SetTextStr;
  322.     property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter;
  323.   end;
  324.  
  325. { TStringList class }
  326.  
  327.   TDuplicates = (dupIgnore, dupAccept, dupError);
  328.  
  329.   PStringItem = ^TStringItem;
  330.   TStringItem = record
  331.     FString: string;
  332.     FObject: TObject;
  333.   end;
  334.  
  335.   PStringItemList = ^TStringItemList;
  336.   TStringItemList = array[0..MaxListSize] of TStringItem;
  337.  
  338.   TStringList = class(TStrings)
  339.   private
  340.     FList: PStringItemList;
  341.     FCount: Integer;
  342.     FCapacity: Integer;
  343.     FSorted: Boolean;
  344.     FDuplicates: TDuplicates;
  345.     FOnChange: TNotifyEvent;
  346.     FOnChanging: TNotifyEvent;
  347.     procedure ExchangeItems(Index1, Index2: Integer);
  348.     procedure Grow;
  349.     procedure QuickSort(L, R: Integer);
  350.     procedure InsertItem(Index: Integer; const S: string);
  351.     procedure SetSorted(Value: Boolean);
  352.   protected
  353.     procedure Changed; virtual;
  354.     procedure Changing; virtual;
  355.     function Get(Index: Integer): string; override;
  356.     function GetCapacity: Integer; override;
  357.     function GetCount: Integer; override;
  358.     function GetObject(Index: Integer): TObject; override;
  359.     procedure Put(Index: Integer; const S: string); override;
  360.     procedure PutObject(Index: Integer; AObject: TObject); override;
  361.     procedure SetCapacity(NewCapacity: Integer); override;
  362.     procedure SetUpdateState(Updating: Boolean); override;
  363.   public
  364.     destructor Destroy; override;
  365.     function Add(const S: string): Integer; override;
  366.     procedure Clear; override;
  367.     procedure Delete(Index: Integer); override;
  368.     procedure Exchange(Index1, Index2: Integer); override;
  369.     function Find(const S: string; var Index: Integer): Boolean; virtual;
  370.     function IndexOf(const S: string): Integer; override;
  371.     procedure Insert(Index: Integer; const S: string); override;
  372.     procedure Sort; virtual;
  373.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  374.     property Sorted: Boolean read FSorted write SetSorted;
  375.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  376.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  377.   end;
  378.  
  379. { TStream abstract class }
  380.  
  381.   TStream = class(TObject)
  382.   private
  383.     function GetPosition: Longint;
  384.     procedure SetPosition(Pos: Longint);
  385.     function GetSize: Longint;
  386.   protected
  387.     procedure SetSize(NewSize: Longint); virtual;
  388.   public
  389.     function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
  390.     function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
  391.     function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
  392.     procedure ReadBuffer(var Buffer; Count: Longint);
  393.     procedure WriteBuffer(const Buffer; Count: Longint);
  394.     function CopyFrom(Source: TStream; Count: Longint): Longint;
  395.     function ReadComponent(Instance: TComponent): TComponent;
  396.     function ReadComponentRes(Instance: TComponent): TComponent;
  397.     procedure WriteComponent(Instance: TComponent);
  398.     procedure WriteComponentRes(const ResName: string; Instance: TComponent);
  399.     procedure WriteDescendent(Instance, Ancestor: TComponent);
  400.     procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
  401.     procedure ReadResHeader;
  402.     property Position: Longint read GetPosition write SetPosition;
  403.     property Size: Longint read GetSize write SetSize;
  404.   end;
  405.  
  406. { THandleStream class }
  407.  
  408.   THandleStream = class(TStream)
  409.   private
  410.     FHandle: Integer;
  411.   protected
  412.     procedure SetSize(NewSize: Longint); override;
  413.   public
  414.     constructor Create(AHandle: Integer);
  415.     function Read(var Buffer; Count: Longint): Longint; override;
  416.     function Write(const Buffer; Count: Longint): Longint; override;
  417.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  418.     property Handle: Integer read FHandle;
  419.   end;
  420.  
  421. { TFileStream class }
  422.  
  423.   TFileStream = class(THandleStream)
  424.   public
  425.     constructor Create(const FileName: string; Mode: Word);
  426.     destructor Destroy; override;
  427.   end;
  428.  
  429. { TCustomMemoryStream abstract class }
  430.  
  431.   TCustomMemoryStream = class(TStream)
  432.   private
  433.     FMemory: Pointer;
  434.     FSize, FPosition: Longint;
  435.   protected
  436.     procedure SetPointer(Ptr: Pointer; Size: Longint);
  437.   public
  438.     function Read(var Buffer; Count: Longint): Longint; override;
  439.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  440.     procedure SaveToStream(Stream: TStream);
  441.     procedure SaveToFile(const FileName: string);
  442.     property Memory: Pointer read FMemory;
  443.   end;
  444.  
  445. { TMemoryStream }
  446.  
  447.   TMemoryStream = class(TCustomMemoryStream)
  448.   private
  449.     FCapacity: Longint;
  450.     procedure SetCapacity(NewCapacity: Longint);
  451.   protected
  452.     function Realloc(var NewCapacity: Longint): Pointer; virtual;
  453.     property Capacity: Longint read FCapacity write SetCapacity;
  454.   public
  455.     destructor Destroy; override;
  456.     procedure Clear;
  457.     procedure LoadFromStream(Stream: TStream);
  458.     procedure LoadFromFile(const FileName: string);
  459.     procedure SetSize(NewSize: Longint); override;
  460.     function Write(const Buffer; Count: Longint): Longint; override;
  461.   end;
  462.  
  463. { TStringStream }
  464.  
  465.   TStringStream = class(TStream)
  466.   private
  467.     FDataString: string;
  468.     FPosition: Integer;
  469.   protected
  470.     procedure SetSize(NewSize: Longint); override;
  471.   public
  472.     constructor Create(const AString: string);
  473.     function Read(var Buffer; Count: Longint): Longint; override;
  474.     function ReadString(Count: Longint): string;
  475.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  476.     function Write(const Buffer; Count: Longint): Longint; override;
  477.     procedure WriteString(const AString: string);
  478.     property DataString: string read FDataString;
  479.   end;
  480.  
  481. { TResourceStream }
  482.  
  483.   TResourceStream = class(TCustomMemoryStream)
  484.   private
  485.     HResInfo: HRSRC;
  486.     HGlobal: THandle;
  487.     procedure Initialize(Instance: THandle; Name, ResType: PChar);
  488.   public
  489.     constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  490.     constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  491.     destructor Destroy; override;
  492.     function Write(const Buffer; Count: Longint): Longint; override;
  493.   end;
  494.  
  495. { TFiler }
  496.  
  497.   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
  498.     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
  499.     vaNil, vaCollection);
  500.  
  501.   TFilerFlag = (ffInherited, ffChildPos);
  502.   TFilerFlags = set of TFilerFlag;
  503.  
  504.   TReaderProc = procedure(Reader: TReader) of object;
  505.   TWriterProc = procedure(Writer: TWriter) of object;
  506.   TStreamProc = procedure(Stream: TStream) of object;
  507.  
  508.   TFiler = class(TObject)
  509.   private
  510.     FStream: TStream;
  511.     FBuffer: Pointer;
  512.     FBufSize: Integer;
  513.     FBufPos: Integer;
  514.     FBufEnd: Integer;
  515.     FRoot: TComponent;
  516.     FAncestor: TPersistent;
  517.     FIgnoreChildren: Boolean;
  518.   public
  519.     constructor Create(Stream: TStream; BufSize: Integer);
  520.     destructor Destroy; override;
  521.     procedure DefineProperty(const Name: string;
  522.       ReadData: TReaderProc; WriteData: TWriterProc;
  523.       HasData: Boolean); virtual; abstract;
  524.     procedure DefineBinaryProperty(const Name: string;
  525.       ReadData, WriteData: TStreamProc;
  526.       HasData: Boolean); virtual; abstract;
  527.     procedure FlushBuffer; virtual; abstract;
  528.     property Root: TComponent read FRoot write FRoot;
  529.     property Ancestor: TPersistent read FAncestor write FAncestor;
  530.     property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
  531.   end;
  532.  
  533. { TReader }
  534.  
  535.   TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
  536.     var Address: Pointer; var Error: Boolean) of object;
  537.   TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
  538.     var Name: string) of object;
  539.   TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
  540.   TReadComponentsProc = procedure(Component: TComponent) of object;
  541.   TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  542.  
  543.   TReader = class(TFiler)
  544.   private
  545.     FOwner: TComponent;
  546.     FParent: TComponent;
  547.     FFixups: TList;
  548.     FLoaded: TList;
  549.     FOnFindMethod: TFindMethodEvent;
  550.     FOnSetName: TSetNameEvent;
  551.     FOnReferenceName: TReferenceNameEvent;
  552.     FOnError: TReaderError;
  553.     FCanHandleExcepts: Boolean;
  554.     FPropName: string;
  555.     procedure CheckValue(Value: TValueType);
  556.     procedure DoFixupReferences;
  557.     procedure FreeFixups;
  558.     function GetPosition: Longint;
  559.     procedure PropertyError;
  560.     procedure ReadBuffer;
  561.     procedure ReadData(Instance: TComponent);
  562.     procedure ReadDataInner(Instance: TComponent);
  563.     procedure ReadProperty(AInstance: TPersistent);
  564.     procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  565.     function ReadSet(SetType: Pointer): Integer;
  566.     procedure SetPosition(Value: Longint);
  567.     procedure SkipSetBody;
  568.     procedure SkipValue;
  569.     procedure SkipProperty;
  570.     procedure SkipComponent(SkipHeader: Boolean);
  571.   protected
  572.     function Error(const Message: string): Boolean; virtual;
  573.     function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
  574.     function NextValue: TValueType;
  575.     procedure SetName(Component: TComponent; var Name: string); virtual;
  576.     procedure ReferenceName(var Name: string); virtual;
  577.   public
  578.     destructor Destroy; override;
  579.     procedure BeginReferences;
  580.     procedure DefineProperty(const Name: string;
  581.       ReadData: TReaderProc; WriteData: TWriterProc;
  582.       HasData: Boolean); override;
  583.     procedure DefineBinaryProperty(const Name: string;
  584.       ReadData, WriteData: TStreamProc;
  585.       HasData: Boolean); override;
  586.     function EndOfList: Boolean;
  587.     procedure EndReferences;
  588.     procedure FixupReferences;
  589.     procedure FlushBuffer; override;
  590.     procedure Read(var Buf; Count: Longint);
  591.     function ReadBoolean: Boolean;
  592.     function ReadChar: Char;
  593.     procedure ReadCollection(Collection: TCollection);
  594.     function ReadComponent(Component: TComponent): TComponent;
  595.     procedure ReadComponents(AOwner, AParent: TComponent;
  596.       Proc: TReadComponentsProc);
  597.     function ReadFloat: Extended;
  598.     function ReadIdent: string;
  599.     function ReadInteger: Longint;
  600.     procedure ReadListBegin;
  601.     procedure ReadListEnd;
  602.     procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  603.     function ReadRootComponent(Root: TComponent): TComponent;
  604.     procedure ReadSignature;
  605.     function ReadStr: string;
  606.     function ReadString: string;
  607.     function ReadValue: TValueType;
  608.     procedure CopyValue(Writer: TWriter); {!!!}
  609.     property Owner: TComponent read FOwner write FOwner;
  610.     property Parent: TComponent read FParent write FParent;
  611.     property Position: Longint read GetPosition write SetPosition;
  612.     property OnError: TReaderError read FOnError write FOnError;
  613.     property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
  614.     property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
  615.     property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
  616.   end;
  617.  
  618. { TWriter }
  619.  
  620.   TWriter = class(TFiler)
  621.   private
  622.     FRootAncestor: TComponent;
  623.     FPropPath: string;
  624.     FAncestorList: TList;
  625.     FAncestorPos: Integer;
  626.     FChildPos: Integer;
  627.     procedure AddAncestor(Component: TComponent);
  628.     function GetPosition: Longint;
  629.     procedure SetPosition(Value: Longint);
  630.     procedure WriteBuffer;
  631.     procedure WriteData(Instance: TComponent); virtual; // linker optimization
  632.     procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  633.     procedure WriteProperties(Instance: TPersistent);
  634.     procedure WritePropName(const PropName: string);
  635.   protected
  636.     procedure WriteBinary(WriteData: TStreamProc);
  637.     procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  638.     procedure WriteValue(Value: TValueType);
  639.   public
  640.     destructor Destroy; override;
  641.     procedure DefineProperty(const Name: string;
  642.       ReadData: TReaderProc; WriteData: TWriterProc;
  643.       HasData: Boolean); override;
  644.     procedure DefineBinaryProperty(const Name: string;
  645.       ReadData, WriteData: TStreamProc;
  646.       HasData: Boolean); override;
  647.     procedure FlushBuffer; override;
  648.     procedure Write(const Buf; Count: Longint);
  649.     procedure WriteBoolean(Value: Boolean);
  650.     procedure WriteCollection(Value: TCollection);
  651.     procedure WriteComponent(Component: TComponent);
  652.     procedure WriteChar(Value: Char);
  653.     procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
  654.     procedure WriteFloat(Value: Extended);
  655.     procedure WriteIdent(const Ident: string);
  656.     procedure WriteInteger(Value: Longint);
  657.     procedure WriteListBegin;
  658.     procedure WriteListEnd;
  659.     procedure WriteRootComponent(Root: TComponent);
  660.     procedure WriteSignature;
  661.     procedure WriteStr(const Value: string);
  662.     procedure WriteString(const Value: string);
  663.     property Position: Longint read GetPosition write SetPosition;
  664.     property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
  665.   end;
  666.  
  667. { TParser }
  668.  
  669.   TParser = class(TObject)
  670.   private
  671.     FStream: TStream;
  672.     FOrigin: Longint;
  673.     FBuffer: PChar;
  674.     FBufPtr: PChar;
  675.     FBufEnd: PChar;
  676.     FSourcePtr: PChar;
  677.     FSourceEnd: PChar;
  678.     FTokenPtr: PChar;
  679.     FStringPtr: PChar;
  680.     FSourceLine: Integer;
  681.     FSaveChar: Char;
  682.     FToken: Char;
  683.     procedure ReadBuffer;
  684.     procedure SkipBlanks;
  685.   public
  686.     constructor Create(Stream: TStream);
  687.     destructor Destroy; override;
  688.     procedure CheckToken(T: Char);
  689.     procedure CheckTokenSymbol(const S: string);
  690.     procedure Error(const Ident: string);
  691.     procedure ErrorFmt(const Ident: string; const Args: array of const);
  692.     procedure ErrorStr(const Message: string);
  693.     procedure HexToBinary(Stream: TStream);
  694.     function NextToken: Char;
  695.     function SourcePos: Longint;
  696.     function TokenComponentIdent: String;
  697.     function TokenFloat: Extended;
  698.     function TokenInt: Longint;
  699.     function TokenString: string;
  700.     function TokenSymbolIs(const S: string): Boolean;
  701.     property SourceLine: Integer read FSourceLine;
  702.     property Token: Char read FToken;
  703.   end;
  704.  
  705. { TThread }
  706.  
  707.   EThread = class(Exception);
  708.  
  709.   TThreadMethod = procedure of object;
  710.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  711.     tpTimeCritical);
  712.  
  713.   TThread = class
  714.   private
  715.     FHandle: THandle;
  716.     FThreadID: THandle;
  717.     FTerminated: Boolean;
  718.     FSuspended: Boolean;
  719.     FFreeOnTerminate: Boolean;
  720.     FFinished: Boolean;
  721.     FReturnValue: Integer;
  722.     FOnTerminate: TNotifyEvent;
  723.     FMethod: TThreadMethod;
  724.     FSynchronizeException: TObject;
  725.     procedure CallOnTerminate;
  726.     function GetPriority: TThreadPriority;
  727.     procedure SetPriority(Value: TThreadPriority);
  728.     procedure SetSuspended(Value: Boolean);
  729.   protected
  730.     procedure DoTerminate; virtual;
  731.     procedure Execute; virtual; abstract;
  732.     procedure Synchronize(Method: TThreadMethod);
  733.     property ReturnValue: Integer read FReturnValue write FReturnValue;
  734.     property Terminated: Boolean read FTerminated;
  735.   public
  736.     constructor Create(CreateSuspended: Boolean);
  737.     destructor Destroy; override;
  738.     procedure Resume;
  739.     procedure Suspend;
  740.     procedure Terminate;
  741.     function WaitFor: Integer;
  742.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  743.     property Handle: THandle read FHandle;
  744.     property Priority: TThreadPriority read GetPriority write SetPriority;
  745.     property Suspended: Boolean read FSuspended write SetSuspended;
  746.     property ThreadID: THandle read FThreadID;
  747.     property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
  748.   end;
  749.  
  750. { TComponent class }
  751.  
  752.   TOperation = (opInsert, opRemove);
  753.   TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
  754.     csDesigning, csAncestor, csUpdating, csFixups);
  755.   TComponentStyle = set of (csInheritable, csCheckPropAvail);
  756.   TGetChildProc = procedure (Child: TComponent) of object;
  757.  
  758.   TComponentName = type string;
  759.  
  760.   IVCLComObject = interface
  761.     ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
  762.     function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  763.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  764.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  765.       NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  766.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  767.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  768.     function SafeCallException(ExceptObject: TObject;
  769.       ExceptAddr: Pointer): Integer;
  770.     procedure FreeOnRelease;
  771.   end;
  772.  
  773.   TComponent = class(TPersistent)
  774.   private
  775.     FOwner: TComponent;
  776.     FName: TComponentName;
  777.     FTag: Longint;
  778.     FComponents: TList;
  779.     FFreeNotifies: TList;
  780.     FDesignInfo: Longint;
  781.     FVCLComObject: Pointer;
  782.     FComponentState: TComponentState;
  783.     function GetComObject: IUnknown;
  784.     function GetComponent(AIndex: Integer): TComponent;
  785.     function GetComponentCount: Integer;
  786.     function GetComponentIndex: Integer;
  787.     procedure Insert(AComponent: TComponent);
  788.     procedure ReadLeft(Reader: TReader);
  789.     procedure ReadTop(Reader: TReader);
  790.     procedure Remove(AComponent: TComponent);
  791.     procedure SetComponentIndex(Value: Integer);
  792.     procedure SetReference(Enable: Boolean);
  793.     procedure WriteLeft(Writer: TWriter);
  794.     procedure WriteTop(Writer: TWriter);
  795.   protected
  796.     FComponentStyle: TComponentStyle;
  797.     procedure ChangeName(const NewName: TComponentName);
  798.     procedure DefineProperties(Filer: TFiler); override;
  799.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
  800.     function GetChildOwner: TComponent; dynamic;
  801.     function GetChildParent: TComponent; dynamic;
  802.     function GetNamePath: string; override;
  803.     function GetOwner: TPersistent; override;
  804.     procedure Loaded; virtual;
  805.     procedure Notification(AComponent: TComponent;
  806.       Operation: TOperation); virtual;
  807.     procedure ReadState(Reader: TReader); virtual;
  808.     procedure SetAncestor(Value: Boolean);
  809.     procedure SetDesigning(Value: Boolean);
  810.     procedure SetName(const NewName: TComponentName); virtual;
  811.     procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
  812.     procedure SetParentComponent(Value: TComponent); dynamic;
  813.     procedure Updating; dynamic;
  814.     procedure Updated; dynamic;
  815.     procedure ValidateRename(AComponent: TComponent;
  816.       const CurName, NewName: string); virtual;
  817.     procedure ValidateContainer(AComponent: TComponent); dynamic;
  818.     procedure ValidateInsert(AComponent: TComponent); dynamic;
  819.     procedure WriteState(Writer: TWriter); virtual;
  820.     { IUnknown }
  821.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  822.     function _AddRef: Integer; stdcall;
  823.     function _Release: Integer; stdcall;
  824.     { IDispatch }
  825.     function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  826.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  827.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  828.       NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  829.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  830.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  831.   public
  832.     constructor Create(AOwner: TComponent); virtual;
  833.     destructor Destroy; override;
  834.     procedure DestroyComponents;
  835.     procedure Destroying;
  836.     function FindComponent(const AName: string): TComponent;
  837.     procedure FreeNotification(AComponent: TComponent);
  838.     procedure FreeOnRelease;
  839.     function GetParentComponent: TComponent; dynamic;
  840.     function HasParent: Boolean; dynamic;
  841.     procedure InsertComponent(AComponent: TComponent);
  842.     procedure RemoveComponent(AComponent: TComponent);
  843.     function SafeCallException(ExceptObject: TObject;
  844.       ExceptAddr: Pointer): Integer; override;
  845.     property ComObject: IUnknown read GetComObject;
  846.     property Components[Index: Integer]: TComponent read GetComponent;
  847.     property ComponentCount: Integer read GetComponentCount;
  848.     property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
  849.     property ComponentState: TComponentState read FComponentState;
  850.     property ComponentStyle: TComponentStyle read FComponentStyle;
  851.     property DesignInfo: Longint read FDesignInfo write FDesignInfo;
  852.     property Owner: TComponent read FOwner;
  853.     property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
  854.   published
  855.     property Name: TComponentName read FName write SetName stored False;
  856.     property Tag: Longint read FTag write FTag default 0;
  857.   end;
  858.  
  859. { TComponent class reference type }
  860.  
  861.   TComponentClass = class of TComponent;
  862.  
  863. { Component registration handlers }
  864.  
  865. var
  866.   RegisterComponentsProc: procedure(const Page: string;
  867.     ComponentClasses: array of TComponentClass) = nil;
  868.   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;
  869.   RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass) = nil;
  870.   CurrentGroup: Integer = -1; { Current design group }
  871.   CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
  872.  
  873. { Point and rectangle constructors }
  874.  
  875. function Point(AX, AY: Integer): TPoint;
  876. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  877. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  878. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  879.  
  880. { Class registration routines }
  881.  
  882. procedure RegisterClass(AClass: TPersistentClass);
  883. procedure RegisterClasses(AClasses: array of TPersistentClass);
  884. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  885. procedure UnRegisterClass(AClass: TPersistentClass);
  886. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  887. procedure UnRegisterModuleClasses(Module: HMODULE);
  888. function FindClass(const ClassName: string): TPersistentClass;
  889. function GetClass(const ClassName: string): TPersistentClass;
  890.  
  891. { Component registration routines }
  892.  
  893. procedure RegisterComponents(const Page: string;
  894.   ComponentClasses: array of TComponentClass);
  895. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  896. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass);
  897.  
  898.  
  899. { Object filing routines }
  900.  
  901. type
  902.   TIdentMapEntry = record
  903.     Value: Integer;
  904.     Name: String;
  905.   end;
  906.  
  907.   TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  908.   TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  909.   TFindGlobalComponent = function(const Name: string): TComponent;
  910.  
  911. var
  912.   MainThreadID: THandle;
  913.   FindGlobalComponent: TFindGlobalComponent;
  914.  
  915. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  916.   IntToIdent: TIntToIdent);
  917. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  918. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  919.  
  920. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  921. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  922. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  923. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  924. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  925. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  926.  
  927. procedure GlobalFixupReferences;
  928. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  929. procedure GetFixupInstanceNames(Root: TComponent;
  930.   const ReferenceRootName: string; Names: TStrings);
  931. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  932.   NewRootName: string);
  933. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  934.  
  935. procedure BeginGlobalLoading;
  936. procedure NotifyGlobalLoading;
  937. procedure EndGlobalLoading;
  938.  
  939. function CollectionsEqual(C1, C2: TCollection): Boolean;
  940.  
  941. { Object conversion routines }
  942.  
  943. procedure ObjectBinaryToText(Input, Output: TStream);
  944. procedure ObjectTextToBinary(Input, Output: TStream);
  945.  
  946. procedure ObjectResourceToText(Input, Output: TStream);
  947. procedure ObjectTextToResource(Input, Output: TStream);
  948.  
  949. { Utility routines }
  950.  
  951. function LineStart(Buffer, BufPos: PChar): PChar;
  952.  
  953. implementation
  954.  
  955. uses Consts, TypInfo;
  956.  
  957. const
  958.   FilerSignature: array[1..4] of Char = 'TPF0';
  959.  
  960. var
  961.   ClassList: TList = nil;
  962.   ClassAliasList: TStringList = nil;
  963.   IntConstList: TList = nil;
  964.  
  965. type
  966.   TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;
  967.  
  968. { Point and rectangle constructors }
  969.  
  970. function Point(AX, AY: Integer): TPoint;
  971. begin
  972.   with Result do
  973.   begin
  974.     X := AX;
  975.     Y := AY;
  976.   end;
  977. end;
  978.  
  979. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  980. begin
  981.   with Result do
  982.   begin
  983.     X := AX;
  984.     Y := AY;
  985.   end;
  986. end;
  987.  
  988. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  989. begin
  990.   with Result do
  991.   begin
  992.     Left := ALeft;
  993.     Top := ATop;
  994.     Right := ARight;
  995.     Bottom := ABottom;
  996.   end;
  997. end;
  998.  
  999. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  1000. begin
  1001.   with Result do
  1002.   begin
  1003.     Left := ALeft;
  1004.     Top := ATop;
  1005.     Right := ALeft + AWidth;
  1006.     Bottom :=  ATop + AHeight;
  1007.   end;
  1008. end;
  1009.  
  1010. { Class registration routines }
  1011.  
  1012. type
  1013.   PFieldClassTable = ^TFieldClassTable;
  1014.   TFieldClassTable = packed record
  1015.     Count: Smallint;
  1016.     Classes: array[0..8191] of ^TPersistentClass;
  1017.   end;
  1018.  
  1019. function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
  1020. asm
  1021.         MOV     EAX,[EAX].vmtFieldTable
  1022.         OR      EAX,EAX
  1023.         JE      @@1
  1024.         MOV     EAX,[EAX+2].Integer
  1025. @@1:
  1026. end;
  1027.  
  1028. procedure ClassNotFound(const ClassName: string);
  1029. begin
  1030.   raise EClassNotFound.Create(Format(SClassNotFound, [ClassName]));
  1031. end;
  1032.  
  1033. function GetClass(const ClassName: string): TPersistentClass;
  1034. var
  1035.   I: Integer;
  1036. begin
  1037.   for I := 0 to ClassList.Count - 1 do
  1038.   begin
  1039.     Result := ClassList[I];
  1040.     if Result.ClassNameIs(ClassName) then Exit;
  1041.   end;
  1042.   I := ClassAliasList.IndexOf(ClassName);
  1043.   if I >= 0 then
  1044.   begin
  1045.     Result := TPersistentClass(ClassAliasList.Objects[I]);
  1046.     Exit;
  1047.   end;
  1048.   Result := nil;
  1049. end;
  1050.  
  1051. function FindClass(const ClassName: string): TPersistentClass;
  1052. begin
  1053.   Result := GetClass(ClassName);
  1054.   if Result = nil then ClassNotFound(ClassName);
  1055. end;
  1056.  
  1057. function FindFieldClass(Instance: TObject;
  1058.   const ClassName: string): TPersistentClass;
  1059. var
  1060.   I: Integer;
  1061.   ClassTable: PFieldClassTable;
  1062.   ClassType: TClass;
  1063. begin
  1064.   ClassType := Instance.ClassType;
  1065.   while ClassType <> TPersistent do
  1066.   begin
  1067.     ClassTable := GetFieldClassTable(ClassType);
  1068.     if ClassTable <> nil then
  1069.       for I := 0 to ClassTable^.Count - 1 do
  1070.       begin
  1071.         Result := ClassTable^.Classes[I]^;
  1072.         if CompareText(Result.ClassName, ClassName) = 0 then Exit;
  1073.       end;
  1074.     ClassType := ClassType.ClassParent;
  1075.   end;
  1076.   Result := FindClass(ClassName);
  1077. end;
  1078.  
  1079. procedure RegisterClass(AClass: TPersistentClass);
  1080. var
  1081.   ClassName: string;
  1082. begin
  1083.   while ClassList.IndexOf(AClass) = -1 do
  1084.   begin
  1085.     ClassName := AClass.ClassName;
  1086.     if GetClass(ClassName) <> nil then
  1087.       raise EFilerError.CreateFmt(SDuplicateClass, [ClassName]);
  1088.     ClassList.Add(AClass);
  1089.     if AClass = TPersistent then Break;
  1090.     AClass := TPersistentClass(AClass.ClassParent);
  1091.   end;
  1092. end;
  1093.  
  1094. procedure RegisterClasses(AClasses: array of TPersistentClass);
  1095. var
  1096.   I: Integer;
  1097. begin
  1098.   for I := Low(AClasses) to High(AClasses) do RegisterClass(AClasses[I]);
  1099. end;
  1100.  
  1101. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  1102. begin
  1103.   RegisterClass(AClass);
  1104.   ClassAliasList.AddObject(Alias, TObject(AClass));
  1105. end;
  1106.  
  1107. procedure UnRegisterClass(AClass: TPersistentClass);
  1108. begin
  1109.   ClassList.Remove(AClass);
  1110. end;
  1111.  
  1112. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  1113. var
  1114.   I: Integer;
  1115. begin
  1116.   for I := Low(AClasses) to High(AClasses) do UnRegisterClass(AClasses[I]);
  1117. end;
  1118.  
  1119. procedure UnRegisterModuleClasses(Module: HMODULE);
  1120. var
  1121.   I: Integer;
  1122.   M: TMemoryBasicInformation;
  1123. begin
  1124.   for I := ClassList.Count - 1 downto 0 do
  1125.   begin
  1126.     VirtualQuery(ClassList[I], M, SizeOf(M));
  1127.     if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then
  1128.       ClassList.Delete(I);
  1129.   end;
  1130.   for I := ClassAliasList.Count - 1 downto 0 do
  1131.   begin
  1132.     VirtualQuery(Pointer(ClassAliasList.Objects[I]), M, SizeOf(M));
  1133.     if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then
  1134.       ClassAliasList.Delete(I);
  1135.   end;
  1136. end;
  1137.  
  1138. { Component registration routines }
  1139.  
  1140. procedure RegisterComponents(const Page: string;
  1141.   ComponentClasses: array of TComponentClass);
  1142. begin
  1143.   if Assigned(RegisterComponentsProc) then
  1144.     RegisterComponentsProc(Page, ComponentClasses)
  1145.   else
  1146.     raise EComponentError.Create(SRegisterError);
  1147. end;
  1148.  
  1149. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  1150. begin
  1151.   if Assigned(RegisterNoIconProc) then
  1152.     RegisterNoIconProc(ComponentClasses)
  1153.   else
  1154.     raise EComponentError.Create(SRegisterError);
  1155. end;
  1156.  
  1157. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass);
  1158. begin
  1159.   if Assigned(RegisterNonActiveXProc) then
  1160.     RegisterNonActiveXProc(ComponentClasses)
  1161.   else
  1162.     raise EComponentError.Create(SRegisterError);
  1163. end;
  1164.  
  1165. { Component filing }
  1166.  
  1167. type
  1168.   TIntConst = class
  1169.     IntegerType: PTypeInfo;
  1170.     IdentToInt: TIdentToInt;
  1171.     IntToIdent: TIntToIdent;
  1172.     constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  1173.       AIntToIdent: TIntToIdent);
  1174.   end;
  1175.  
  1176. constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  1177.   AIntToIdent: TIntToIdent);
  1178. begin
  1179.   IntegerType := AIntegerType;
  1180.   IdentToInt := AIdentToInt;
  1181.   IntToIdent := AIntToIdent;
  1182. end;
  1183.  
  1184. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  1185.   IntToIdent: TIntToIdent);
  1186. begin
  1187.   IntConstList.Add(TIntConst.Create(IntegerType, IdentToInt, IntToIdent));
  1188. end;
  1189.  
  1190. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  1191. var
  1192.   I: Integer;
  1193. begin
  1194.   for I := Low(Map) to High(Map) do
  1195.     if CompareText(Map[I].Name, Ident) = 0 then
  1196.     begin
  1197.       Result := True;
  1198.       Int := Map[I].Value;
  1199.       Exit;
  1200.     end;
  1201.   Result := False;
  1202. end;
  1203.  
  1204. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  1205. var
  1206.   I: Integer;
  1207. begin
  1208.   for I := Low(Map) to High(Map) do
  1209.     if Map[I].Value = Int then
  1210.     begin
  1211.       Result := True;
  1212.       Ident := Map[I].Name;
  1213.       Exit;
  1214.     end;
  1215.   Result := False;
  1216. end;
  1217.  
  1218.  
  1219. function InternalReadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean;
  1220. var
  1221.   HRsrc: THandle;
  1222. begin                   { avoid possible EResNotFound exception }
  1223.   if HInst = 0 then HInst := HInstance;
  1224.   HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);
  1225.   Result := HRsrc <> 0;
  1226.   if not Result then Exit;
  1227.   FreeResource(HRsrc);
  1228.   with TResourceStream.Create(HInst, ResName, RT_RCDATA) do
  1229.   try
  1230.     Instance := ReadComponent(Instance);
  1231.   finally
  1232.     Free;
  1233.   end;
  1234.   Result := True;
  1235. end;
  1236.  
  1237. var
  1238.   GlobalLoaded: TList;
  1239.   GlobalLists: TList;
  1240.  
  1241. procedure BeginGlobalLoading;
  1242. begin
  1243.   GlobalLists.Add(GlobalLoaded);
  1244.   GlobalLoaded := TList.Create;
  1245. end;
  1246.  
  1247. procedure NotifyGlobalLoading;
  1248. var
  1249.   I: Integer;
  1250. begin
  1251.   for I := 0 to GlobalLoaded.Count - 1 do
  1252.     TComponent(GlobalLoaded[I]).Loaded;
  1253. end;
  1254.  
  1255. procedure EndGlobalLoading;
  1256. begin
  1257.   GlobalLoaded.Free;
  1258.   GlobalLoaded := GlobalLists.Last;
  1259.   GlobalLists.Delete(GlobalLists.Count - 1);
  1260. end;
  1261.  
  1262. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  1263.  
  1264.   function InitComponent(ClassType: TClass): Boolean;
  1265.   begin
  1266.     Result := False;
  1267.     if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit;
  1268.     Result := InitComponent(ClassType.ClassParent);
  1269.     Result := InternalReadComponentRes(ClassType.ClassName, FindResourceHInstance(
  1270.       FindClassHInstance(ClassType)), Instance) or Result;
  1271.   end;
  1272.  
  1273. begin
  1274.   BeginGlobalLoading;
  1275.   try
  1276.     Result := InitComponent(Instance.ClassType);
  1277.     NotifyGlobalLoading;
  1278.   finally
  1279.     EndGlobalLoading;
  1280.   end;
  1281. end;
  1282.  
  1283. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  1284. begin
  1285.   Result := InternalReadComponentRes(ResName, FindResourceHInstance(
  1286.     FindClassHInstance(Instance.ClassType)), Instance);
  1287. end;
  1288.  
  1289. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  1290. var
  1291.   HInstance: THandle;
  1292. begin
  1293.   if Instance <> nil then
  1294.     HInstance := FindResourceHInstance(FindClassHInstance(Instance.ClassType))
  1295.   else HInstance := 0;
  1296.   if InternalReadComponentRes(ResName, HInstance, Instance) then
  1297.     Result := Instance else
  1298.     raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
  1299. end;
  1300.  
  1301. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  1302. var
  1303.   Instance: TComponent;
  1304. begin
  1305.   Instance := nil;
  1306.   if InternalReadComponentRes(ResName, HInstance, Instance) then
  1307.     Result := Instance else
  1308.     raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
  1309. end;
  1310.  
  1311. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  1312. var
  1313.   Stream: TStream;
  1314. begin
  1315.   Stream := TFileStream.Create(FileName, fmOpenRead);
  1316.   try
  1317.     Result := Stream.ReadComponentRes(Instance);
  1318.   finally
  1319.     Stream.Free;
  1320.   end;
  1321. end;
  1322.  
  1323. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  1324. var
  1325.   Stream: TStream;
  1326. begin
  1327.   Stream := TFileStream.Create(FileName, fmCreate);
  1328.   try
  1329.     Stream.WriteComponentRes(Instance.ClassName, Instance);
  1330.   finally
  1331.     Stream.Free;
  1332.   end;
  1333. end;
  1334.  
  1335. function CollectionsEqual(C1, C2: TCollection): Boolean;
  1336. var
  1337.   S1, S2: TMemoryStream;
  1338.  
  1339.   procedure WriteCollection(Stream: TStream; Collection: TCollection);
  1340.   var
  1341.     Writer: TWriter;
  1342.   begin
  1343.     Writer := TWriter.Create(Stream, 1024);
  1344.     try
  1345.       Writer.WriteCollection(Collection);
  1346.     finally
  1347.       Writer.Free;
  1348.     end;
  1349.   end;
  1350.  
  1351. begin
  1352.   Result := False;
  1353.   if C1.ClassType <> C2.ClassType then Exit;
  1354.   if C1.Count <> C2.Count then Exit;
  1355.   S1 := TMemoryStream.Create;
  1356.   try
  1357.     WriteCollection(S1, C1);
  1358.     S2 := TMemoryStream.Create;
  1359.     try
  1360.       WriteCollection(S2, C2);
  1361.       Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
  1362.     finally
  1363.       S2.Free;
  1364.     end;
  1365.   finally
  1366.     S1.Free;
  1367.   end;
  1368. end;
  1369.  
  1370. { Utility routines }
  1371.  
  1372. function LineStart(Buffer, BufPos: PChar): PChar; assembler;
  1373. asm
  1374.         PUSH    EDI
  1375.         MOV     EDI,EDX
  1376.         MOV     ECX,EDX
  1377.         SUB     ECX,EAX
  1378.         SUB     ECX,1
  1379.         JBE     @@1
  1380.         MOV     EDX,EAX
  1381.         DEC     EDI
  1382.         MOV     AL,0AH
  1383.         STD
  1384.         REPNE   SCASB
  1385.         CLD
  1386.         MOV     EAX,EDX
  1387.         JNE     @@1
  1388.         LEA     EAX,[EDI+2]
  1389. @@1:    POP     EDI
  1390. end;
  1391.  
  1392. { TList }
  1393.  
  1394. destructor TList.Destroy;
  1395. begin
  1396.   Clear;
  1397. end;
  1398.  
  1399. function TList.Add(Item: Pointer): Integer;
  1400. begin
  1401.   Result := FCount;
  1402.   if Result = FCapacity then Grow;
  1403.   FList^[Result] := Item;
  1404.   Inc(FCount);
  1405. end;
  1406.  
  1407. procedure TList.Clear;
  1408. begin
  1409.   SetCount(0);
  1410.   SetCapacity(0);
  1411. end;
  1412.  
  1413. procedure TList.Delete(Index: Integer);
  1414. begin
  1415.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  1416.   Dec(FCount);
  1417.   if Index < FCount then
  1418.     System.Move(FList^[Index + 1], FList^[Index],
  1419.       (FCount - Index) * SizeOf(Pointer));
  1420. end;
  1421.  
  1422. class procedure TList.Error(const Msg: string; Data: Integer);
  1423.  
  1424.   function ReturnAddr: Pointer;
  1425.   asm
  1426.           MOV     EAX,[EBP+4]
  1427.   end;
  1428.  
  1429. begin
  1430.   raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
  1431. end;
  1432.  
  1433. procedure TList.Exchange(Index1, Index2: Integer);
  1434. var
  1435.   Item: Pointer;
  1436. begin
  1437.   if (Index1 < 0) or (Index1 >= FCount) then Error(SListIndexError, Index1);
  1438.   if (Index2 < 0) or (Index2 >= FCount) then Error(SListIndexError, Index2);
  1439.   Item := FList^[Index1];
  1440.   FList^[Index1] := FList^[Index2];
  1441.   FList^[Index2] := Item;
  1442. end;
  1443.  
  1444. function TList.Expand: TList;
  1445. begin
  1446.   if FCount = FCapacity then Grow;
  1447.   Result := Self;
  1448. end;
  1449.  
  1450. function TList.First: Pointer;
  1451. begin
  1452.   Result := Get(0);
  1453. end;
  1454.  
  1455. function TList.Get(Index: Integer): Pointer;
  1456. begin
  1457.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  1458.   Result := FList^[Index];
  1459. end;
  1460.  
  1461. procedure TList.Grow;
  1462. var
  1463.   Delta: Integer;
  1464. begin
  1465.   if FCapacity > 64 then Delta := FCapacity div 4 else
  1466.     if FCapacity > 8 then Delta := 16 else
  1467.       Delta := 4;
  1468.   SetCapacity(FCapacity + Delta);
  1469. end;
  1470.  
  1471. function TList.IndexOf(Item: Pointer): Integer;
  1472. begin
  1473.   Result := 0;
  1474.   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  1475.   if Result = FCount then Result := -1;
  1476. end;
  1477.  
  1478. procedure TList.Insert(Index: Integer; Item: Pointer);
  1479. begin
  1480.   if (Index < 0) or (Index > FCount) then Error(SListIndexError, Index);
  1481.   if FCount = FCapacity then Grow;
  1482.   if Index < FCount then
  1483.     System.Move(FList^[Index], FList^[Index + 1],
  1484.       (FCount - Index) * SizeOf(Pointer));
  1485.   FList^[Index] := Item;
  1486.   Inc(FCount);
  1487. end;
  1488.  
  1489. function TList.Last: Pointer;
  1490. begin
  1491.   Result := Get(FCount - 1);
  1492. end;
  1493.  
  1494. procedure TList.Move(CurIndex, NewIndex: Integer);
  1495. var
  1496.   Item: Pointer;
  1497. begin
  1498.   if CurIndex <> NewIndex then
  1499.   begin
  1500.     if (NewIndex < 0) or (NewIndex >= FCount) then Error(SListIndexError, NewIndex);
  1501.     Item := Get(CurIndex);
  1502.     Delete(CurIndex);
  1503.     Insert(NewIndex, Item);
  1504.   end;
  1505. end;
  1506.  
  1507. procedure TList.Put(Index: Integer; Item: Pointer);
  1508. begin
  1509.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  1510.   FList^[Index] := Item;
  1511. end;
  1512.  
  1513. function TList.Remove(Item: Pointer): Integer;
  1514. begin
  1515.   Result := IndexOf(Item);
  1516.   if Result <> -1 then Delete(Result);
  1517. end;
  1518.  
  1519. procedure TList.Pack;
  1520. var
  1521.   I: Integer;
  1522. begin
  1523.   for I := FCount - 1 downto 0 do if Items[I] = nil then Delete(I);
  1524. end;
  1525.  
  1526. procedure TList.SetCapacity(NewCapacity: Integer);
  1527. begin
  1528.   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  1529.     Error(SListCapacityError, NewCapacity);
  1530.   if NewCapacity <> FCapacity then
  1531.   begin
  1532.     ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  1533.     FCapacity := NewCapacity;
  1534.   end;
  1535. end;
  1536.  
  1537. procedure TList.SetCount(NewCount: Integer);
  1538. begin
  1539.   if (NewCount < 0) or (NewCount > MaxListSize) then
  1540.     Error(SListCountError, NewCount);
  1541.   if NewCount > FCapacity then SetCapacity(NewCount);
  1542.   if NewCount > FCount then
  1543.     FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0);
  1544.   FCount := NewCount;
  1545. end;
  1546.  
  1547. procedure QuickSort(SortList: PPointerList; L, R: Integer;
  1548.   SCompare: TListSortCompare);
  1549. var
  1550.   I, J: Integer;
  1551.   P, T: Pointer;
  1552. begin
  1553.   repeat
  1554.     I := L;
  1555.     J := R;
  1556.     P := SortList^[(L + R) shr 1];
  1557.     repeat
  1558.       while SCompare(SortList^[I], P) < 0 do Inc(I);
  1559.       while SCompare(SortList^[J], P) > 0 do Dec(J);
  1560.       if I <= J then
  1561.       begin
  1562.         T := SortList^[I];
  1563.         SortList^[I] := SortList^[J];
  1564.         SortList^[J] := T;
  1565.         Inc(I);
  1566.         Dec(J);
  1567.       end;
  1568.     until I > J;
  1569.     if L < J then QuickSort(SortList, L, J, SCompare);
  1570.     L := I;
  1571.   until I >= R;
  1572. end;
  1573.  
  1574. procedure TList.Sort(Compare: TListSortCompare);
  1575. begin
  1576.   if (FList <> nil) and (Count > 0) then
  1577.     QuickSort(FList, 0, Count - 1, Compare);
  1578. end;
  1579.  
  1580. { TThreadList }
  1581.  
  1582. constructor TThreadList.Create;
  1583. begin
  1584.   inherited Create;
  1585.   InitializeCriticalSection(FLock);
  1586.   FList := TList.Create;
  1587. end;
  1588.  
  1589. destructor TThreadList.Destroy;
  1590. begin
  1591.   LockList;    // Make sure nobody else is inside the list.
  1592.   try
  1593.     FList.Free;
  1594.     inherited Destroy;
  1595.   finally
  1596.     UnlockList;
  1597.     DeleteCriticalSection(FLock);
  1598.   end;
  1599. end;
  1600.  
  1601. procedure TThreadList.Add(Item: Pointer);
  1602. begin
  1603.   LockList;
  1604.   try
  1605.     if FList.IndexOf(Item) = -1 then
  1606.       FList.Add(Item);
  1607.   finally
  1608.     UnlockList;
  1609.   end;
  1610. end;
  1611.  
  1612. procedure TThreadList.Clear;
  1613. begin
  1614.   LockList;
  1615.   try
  1616.     FList.Clear;
  1617.   finally
  1618.     UnlockList;
  1619.   end;
  1620. end;
  1621.  
  1622. function  TThreadList.LockList: TList;
  1623. begin
  1624.   EnterCriticalSection(FLock);
  1625.   Result := FList;
  1626. end;
  1627.  
  1628. procedure TThreadList.Remove(Item: Pointer);
  1629. begin
  1630.   LockList;
  1631.   try
  1632.     FList.Remove(Item);
  1633.   finally
  1634.     UnlockList;
  1635.   end;
  1636. end;
  1637.  
  1638. procedure TThreadList.UnlockList;
  1639. begin
  1640.   LeaveCriticalSection(FLock);
  1641. end;
  1642.  
  1643.  
  1644. { TBits }
  1645.  
  1646. const
  1647.   BitsPerInt = SizeOf(Integer) * 8;
  1648.  
  1649. type
  1650.   TBitEnum = 0..BitsPerInt - 1;
  1651.   TBitSet = set of TBitEnum;
  1652.   PBitArray = ^TBitArray;
  1653.   TBitArray = array[0..4096] of TBitSet;
  1654.  
  1655. destructor TBits.Destroy;
  1656. begin
  1657.   SetSize(0);
  1658.   inherited Destroy;
  1659. end;
  1660.  
  1661. procedure TBits.Error;
  1662. begin
  1663.   raise EBitsError.Create(SBitsIndexError);
  1664. end;
  1665.  
  1666. procedure TBits.SetSize(Value: Integer);
  1667. var
  1668.   NewMem: Pointer;
  1669.   NewMemSize: Integer;
  1670.   OldMemSize: Integer;
  1671.  
  1672.   function Min(X, Y: Integer): Integer;
  1673.   begin
  1674.     Result := X;
  1675.     if X > Y then Result := Y;
  1676.   end;
  1677.  
  1678. begin
  1679.   if Value <> Size then
  1680.   begin
  1681.     if Value < 0 then Error;
  1682.     NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  1683.     OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  1684.     if NewMemSize <> OldMemSize then
  1685.     begin
  1686.       NewMem := nil;
  1687.       if NewMemSize <> 0 then
  1688.       begin
  1689.         GetMem(NewMem, NewMemSize);
  1690.         FillChar(NewMem^, NewMemSize, 0);
  1691.       end;
  1692.       if OldMemSize <> 0 then
  1693.       begin
  1694.         if NewMem <> nil then
  1695.           Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize));
  1696.         FreeMem(FBits, OldMemSize);
  1697.       end;
  1698.       FBits := NewMem;
  1699.     end;
  1700.     FSize := Value;
  1701.   end;
  1702. end;
  1703.  
  1704.  
  1705. procedure TBits.SetBit(Index: Integer; Value: Boolean); assembler;
  1706. asm
  1707.         CMP     Index,[EAX].FSize
  1708.         JAE     @@Size
  1709.  
  1710. @@1:    MOV     EAX,[EAX].FBits
  1711.         OR      Value,Value
  1712.         JZ      @@2
  1713.         BTS     [EAX],Index
  1714.         RET
  1715.  
  1716. @@2:    BTR     [EAX],Index
  1717.         RET
  1718.  
  1719. @@Size: CMP     Index,0
  1720.         JL      TBits.Error
  1721.         PUSH    Self
  1722.         PUSH    Index
  1723.         PUSH    ECX {Value}
  1724.         INC     Index
  1725.         CALL    TBits.SetSize
  1726.         POP     ECX {Value}
  1727.         POP     Index
  1728.         POP     Self
  1729.         JMP     @@1
  1730. end;
  1731.  
  1732. function TBits.GetBit(Index: Integer): Boolean; assembler;
  1733. asm
  1734.         CMP     Index,[EAX].FSize
  1735.         JAE     TBits.Error
  1736.         MOV     EAX,[EAX].FBits
  1737.         BT      [EAX],Index
  1738.         SBB     EAX,EAX
  1739.         AND     EAX,1
  1740. end;
  1741.  
  1742.  
  1743. function TBits.OpenBit: Integer;
  1744. var
  1745.   I: Integer;
  1746.   B: TBitSet;
  1747.   J: TBitEnum;
  1748.   E: Integer;
  1749. begin
  1750.   E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  1751.   for I := 0 to E do
  1752.     if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then
  1753.     begin
  1754.       B := PBitArray(FBits)^[I];
  1755.       for J := Low(J) to High(J) do
  1756.       begin
  1757.         if not (J in B) then
  1758.         begin
  1759.           Result := I * BitsPerInt + J;
  1760.           if Result >= Size then Result := Size;
  1761.           Exit;
  1762.         end;
  1763.       end;
  1764.     end;
  1765.   Result := Size;
  1766. end;
  1767.  
  1768. { TPersistent }
  1769.  
  1770. procedure TPersistent.Assign(Source: TPersistent);
  1771. begin
  1772.   if Source <> nil then Source.AssignTo(Self) else AssignError(nil);
  1773. end;
  1774.  
  1775. procedure TPersistent.AssignError(Source: TPersistent);
  1776. var
  1777.   SourceName: string;
  1778. begin
  1779.   if Source <> nil then
  1780.     SourceName := Source.ClassName else
  1781.     SourceName := 'nil';
  1782.   raise EConvertError.CreateFmt(SAssignError, [SourceName, ClassName]);
  1783. end;
  1784.  
  1785. procedure TPersistent.AssignTo(Dest: TPersistent);
  1786. begin
  1787.   Dest.AssignError(Self);
  1788. end;
  1789.  
  1790. procedure TPersistent.DefineProperties(Filer: TFiler);
  1791. begin
  1792. end;
  1793.  
  1794. function TPersistent.GetNamePath: string;
  1795. var
  1796.   S: string;
  1797. begin
  1798.   Result := ClassName;
  1799.   if (GetOwner <> nil) then
  1800.   begin
  1801.     S := GetOwner.GetNamePath;
  1802.     if S <> '' then
  1803.       Result := S + '.' + Result;
  1804.   end;
  1805. end;
  1806.  
  1807. function TPersistent.GetOwner: TPersistent;
  1808. begin
  1809.   Result := nil;
  1810. end;
  1811.  
  1812. { TCollectionItem }
  1813.  
  1814. constructor TCollectionItem.Create(Collection: TCollection);
  1815. begin
  1816.   SetCollection(Collection);
  1817. end;
  1818.  
  1819. destructor TCollectionItem.Destroy;
  1820. begin
  1821.   SetCollection(nil);
  1822. end;
  1823.  
  1824. procedure TCollectionItem.Changed(AllItems: Boolean);
  1825. var
  1826.   Item: TCollectionItem;
  1827. begin
  1828.   if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  1829.   begin
  1830.     if AllItems then Item := nil else Item := Self;
  1831.     FCollection.Update(Item);
  1832.   end;
  1833. end;
  1834.  
  1835. function TCollectionItem.GetIndex: Integer;
  1836. begin
  1837.   if FCollection <> nil then
  1838.     Result := FCollection.FItems.IndexOf(Self) else
  1839.     Result := -1;
  1840. end;
  1841.  
  1842. function TCollectionItem.GetDisplayName: string;
  1843. begin
  1844.   Result := ClassName;
  1845. end;
  1846.  
  1847. function TCollectionItem.GetNamePath: string;
  1848. begin
  1849.   if FCollection <> nil then
  1850.     Result := Format('%s[%d]',[FCollection.GetNamePath, Index])
  1851.   else
  1852.     Result := ClassName;
  1853. end;
  1854.  
  1855. function TCollectionItem.GetOwner: TPersistent;
  1856. begin
  1857.   Result := FCollection;
  1858. end;
  1859.  
  1860. procedure TCollectionItem.SetCollection(Value: TCollection);
  1861. begin
  1862.   if FCollection <> Value then
  1863.   begin
  1864.     if FCollection <> nil then FCollection.RemoveItem(Self);
  1865.     if Value <> nil then Value.InsertItem(Self);
  1866.   end;
  1867. end;
  1868.  
  1869. procedure TCollectionItem.SetDisplayName(const Value: string);
  1870. begin
  1871.   Changed(False);
  1872. end;
  1873.  
  1874. procedure TCollectionItem.SetIndex(Value: Integer);
  1875. var
  1876.   CurIndex: Integer;
  1877. begin
  1878.   CurIndex := GetIndex;
  1879.   if (CurIndex >= 0) and (CurIndex <> Value) then
  1880.   begin
  1881.     FCollection.FItems.Move(CurIndex, Value);
  1882.     Changed(True);
  1883.   end;
  1884. end;
  1885.  
  1886. { TCollection }
  1887.  
  1888. constructor TCollection.Create(ItemClass: TCollectionItemClass);
  1889. begin
  1890.   FItemClass := ItemClass;
  1891.   FItems := TList.Create;
  1892. end;
  1893.  
  1894. destructor TCollection.Destroy;
  1895. begin
  1896.   FUpdateCount := 1;
  1897.   if FItems <> nil then Clear;
  1898.   FItems.Free;
  1899. end;
  1900.  
  1901. function TCollection.Add: TCollectionItem;
  1902. begin
  1903.   Result := FItemClass.Create(Self);
  1904. end;
  1905.  
  1906. procedure TCollection.Assign(Source: TPersistent);
  1907. var
  1908.   I: Integer;
  1909. begin
  1910.   if Source is TCollection then
  1911.   begin
  1912.     BeginUpdate;
  1913.     try
  1914.       Clear;
  1915.       for I := 0 to TCollection(Source).Count - 1 do
  1916.         Add.Assign(TCollection(Source).Items[I]);
  1917.     finally
  1918.       EndUpdate;
  1919.     end;
  1920.     Exit;
  1921.   end;
  1922.   inherited Assign(Source);
  1923. end;
  1924.  
  1925. procedure TCollection.BeginUpdate;
  1926. begin
  1927.   Inc(FUpdateCount);
  1928. end;
  1929.  
  1930. procedure TCollection.Changed;
  1931. begin
  1932.   if FUpdateCount = 0 then Update(nil);
  1933. end;
  1934.  
  1935. procedure TCollection.Clear;
  1936. begin
  1937.   if FItems.Count > 0 then
  1938.   begin
  1939.     BeginUpdate;
  1940.     try
  1941.       while FItems.Count > 0 do TCollectionItem(FItems.Last).Free;
  1942.     finally
  1943.       EndUpdate;
  1944.     end;
  1945.   end;
  1946. end;
  1947.  
  1948. procedure TCollection.EndUpdate;
  1949. begin
  1950.   Dec(FUpdateCount);
  1951.   Changed;
  1952. end;
  1953.  
  1954. function TCollection.FindItemID(ID: Integer): TCollectionItem;
  1955. var
  1956.   I: Integer;
  1957. begin
  1958.   for I := 0 to FItems.Count-1 do
  1959.   begin
  1960.     Result := TCollectionItem(FItems[I]);
  1961.     if Result.ID = ID then Exit;
  1962.   end;
  1963.   Result := nil;
  1964. end;
  1965.  
  1966. function TCollection.GetAttrCount: Integer;
  1967. begin
  1968.   Result := 0;
  1969. end;
  1970.  
  1971. function TCollection.GetAttr(Index: Integer): string;
  1972. begin
  1973.   Result := '';
  1974. end;
  1975.  
  1976. function TCollection.GetItemAttr(Index, ItemIndex: Integer): string;
  1977. begin
  1978.   Result := Items[ItemIndex].DisplayName;
  1979. end;
  1980.  
  1981. function TCollection.GetCount: Integer;
  1982. begin
  1983.   Result := FItems.Count;
  1984. end;
  1985.  
  1986. function TCollection.GetItem(Index: Integer): TCollectionItem;
  1987. begin
  1988.   Result := FItems[Index];
  1989. end;
  1990.  
  1991. function TCollection.GetNamePath: string;
  1992. var
  1993.   S, P: string;
  1994. begin
  1995.   Result := ClassName;
  1996.   if GetOwner = nil then Exit;
  1997.   S := GetOwner.GetNamePath;
  1998.   if S = '' then Exit;
  1999.   P := PropName;
  2000.   if P = '' then Exit;
  2001.   Result := S + '.' + P;
  2002. end;
  2003.  
  2004. function TCollection.GetPropName: string;
  2005. var
  2006.   I: Integer;
  2007.   Props: PPropList;
  2008.   TypeData: PTypeData;
  2009.   Owner: TPersistent;
  2010. begin
  2011.   Result := FPropName;
  2012.   Owner := GetOwner;
  2013.   if (Result <> '') or (Owner = nil) or (Owner.ClassInfo = nil) then Exit;
  2014.   TypeData := GetTypeData(Owner.ClassInfo);
  2015.   if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit;
  2016.   GetMem(Props, TypeData^.PropCount * sizeof(Pointer));
  2017.   try
  2018.     GetPropInfos(Owner.ClassInfo, Props);
  2019.     for I := 0 to TypeData^.PropCount-1 do
  2020.     begin
  2021.       with Props^[I]^ do
  2022.         if (PropType^^.Kind = tkClass) and
  2023.           (GetOrdProp(Owner, Props^[I]) = Integer(Self)) then
  2024.           FPropName := Name;
  2025.     end;
  2026.   finally
  2027.     Freemem(Props);
  2028.   end;
  2029.   Result := FPropName;
  2030. end;
  2031.  
  2032. procedure TCollection.InsertItem(Item: TCollectionItem);
  2033. begin
  2034.   if not (Item is FItemClass) then TList.Error(SInvalidProperty, 0);
  2035.   FItems.Add(Item);
  2036.   Item.FCollection := Self;
  2037.   Item.FID := FNextID;
  2038.   Inc(FNextID);
  2039.   SetItemName(Item);
  2040.   Changed;
  2041. end;
  2042.  
  2043. procedure TCollection.RemoveItem(Item: TCollectionItem);
  2044. begin
  2045.   FItems.Remove(Item);
  2046.   Item.FCollection := nil;
  2047.   Changed;
  2048. end;
  2049.  
  2050. procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem);
  2051. begin
  2052.   TCollectionItem(FItems[Index]).Assign(Value);
  2053. end;
  2054.  
  2055. procedure TCollection.SetItemName(Item: TCollectionItem);
  2056. begin
  2057. end;
  2058.  
  2059. procedure TCollection.Update(Item: TCollectionItem);
  2060. begin
  2061. end;
  2062.  
  2063. { TStrings }
  2064. destructor TStrings.Destroy;
  2065. begin
  2066.   StringsAdapter := nil;
  2067.   inherited Destroy;
  2068. end;
  2069.  
  2070. function TStrings.Add(const S: string): Integer;
  2071. begin
  2072.   Result := GetCount;
  2073.   Insert(Result, S);
  2074. end;
  2075.  
  2076. function TStrings.AddObject(const S: string; AObject: TObject): Integer;
  2077. begin
  2078.   Result := Add(S);
  2079.   PutObject(Result, AObject);
  2080. end;
  2081.  
  2082. procedure TStrings.Append(const S: string);
  2083. begin
  2084.   Add(S);
  2085. end;
  2086.  
  2087. procedure TStrings.AddStrings(Strings: TStrings);
  2088. var
  2089.   I: Integer;
  2090. begin
  2091.   BeginUpdate;
  2092.   try
  2093.     for I := 0 to Strings.Count - 1 do
  2094.       AddObject(Strings[I], Strings.Objects[I]);
  2095.   finally
  2096.     EndUpdate;
  2097.   end;
  2098. end;
  2099.  
  2100. procedure TStrings.Assign(Source: TPersistent);
  2101. begin
  2102.   if Source is TStrings then
  2103.   begin
  2104.     BeginUpdate;
  2105.     try
  2106.       Clear;
  2107.       AddStrings(TStrings(Source));
  2108.     finally
  2109.       EndUpdate;
  2110.     end;
  2111.     Exit;
  2112.   end;
  2113.   inherited Assign(Source);
  2114. end;
  2115.  
  2116. procedure TStrings.BeginUpdate;
  2117. begin
  2118.   if FUpdateCount = 0 then SetUpdateState(True);
  2119.   Inc(FUpdateCount);
  2120. end;
  2121.  
  2122. procedure TStrings.DefineProperties(Filer: TFiler);
  2123.  
  2124.   function DoWrite: Boolean;
  2125.   begin
  2126.     if Filer.Ancestor <> nil then
  2127.     begin
  2128.       Result := True;
  2129.       if Filer.Ancestor is TStrings then
  2130.         Result := not Equals(TStrings(Filer.Ancestor))
  2131.     end
  2132.     else Result := Count > 0;
  2133.   end;
  2134.  
  2135. begin
  2136.   Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite);
  2137. end;
  2138.  
  2139. procedure TStrings.EndUpdate;
  2140. begin
  2141.   Dec(FUpdateCount);
  2142.   if FUpdateCount = 0 then SetUpdateState(False);
  2143. end;
  2144.  
  2145. function TStrings.Equals(Strings: TStrings): Boolean;
  2146. var
  2147.   I, Count: Integer;
  2148. begin
  2149.   Result := False;
  2150.   Count := GetCount;
  2151.   if Count <> Strings.GetCount then Exit;
  2152.   for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit;
  2153.   Result := True;
  2154. end;
  2155.  
  2156. procedure TStrings.Error(const Msg: string; Data: Integer);
  2157.  
  2158.   function ReturnAddr: Pointer;
  2159.   asm
  2160.           MOV     EAX,[EBP+4]
  2161.   end;
  2162.  
  2163. begin
  2164.   raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;
  2165. end;
  2166.  
  2167. procedure TStrings.Exchange(Index1, Index2: Integer);
  2168. var
  2169.   TempObject: TObject;
  2170.   TempString: string;
  2171. begin
  2172.   BeginUpdate;
  2173.   try
  2174.     TempString := Strings[Index1];
  2175.     TempObject := Objects[Index1];
  2176.     Strings[Index1] := Strings[Index2];
  2177.     Objects[Index1] := Objects[Index2];
  2178.     Strings[Index2] := TempString;
  2179.     Objects[Index2] := TempObject;
  2180.   finally
  2181.     EndUpdate;
  2182.   end;
  2183. end;
  2184.  
  2185. function TStrings.GetCapacity: Integer;
  2186. begin  // descendants may optionally override/replace this default implementation
  2187.   Result := Count;
  2188. end;
  2189.  
  2190. function TStrings.GetCommaText: string;
  2191. var
  2192.   S: string;
  2193.   P: PChar;
  2194.   I, Count: Integer;
  2195. begin
  2196.   Count := GetCount;
  2197.   if (Count = 1) and (Get(0) = '') then
  2198.     Result := '""'
  2199.   else
  2200.   begin
  2201.     Result := '';
  2202.     for I := 0 to Count - 1 do
  2203.     begin
  2204.       S := Get(I);
  2205.       P := PChar(S);
  2206.       while not (P^ in [#0..' ','"',',']) do P := CharNext(P);
  2207.       if (P <> #0) then S := AnsiQuotedStr(S, '"');
  2208.       Result := Result + S + ',';
  2209.     end;
  2210.     System.Delete(Result, Length(Result), 1);
  2211.   end;
  2212. end;
  2213.  
  2214. function TStrings.GetName(Index: Integer): string;
  2215. var
  2216.   P: Integer;
  2217. begin
  2218.   Result := Get(Index);
  2219.   P := AnsiPos('=', Result);
  2220.   if P <> 0 then
  2221.     SetLength(Result, P-1) else
  2222.     SetLength(Result, 0);
  2223. end;
  2224.  
  2225. function TStrings.GetObject(Index: Integer): TObject;
  2226. begin
  2227.   Result := nil;
  2228. end;
  2229.  
  2230. function TStrings.GetText: PChar;
  2231. begin
  2232.   Result := StrNew(PChar(GetTextStr));
  2233. end;
  2234.  
  2235. function TStrings.GetTextStr: string;
  2236. var
  2237.   I, L, Size, Count: Integer;
  2238.   P: PChar;
  2239.   S: string;
  2240. begin
  2241.   Count := GetCount;
  2242.   Size := 0;
  2243.   for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + 2);
  2244.   SetString(Result, nil, Size);
  2245.   P := Pointer(Result);
  2246.   for I := 0 to Count - 1 do
  2247.   begin
  2248.     S := Get(I);
  2249.     L := Length(S);
  2250.     if L <> 0 then
  2251.     begin
  2252.       System.Move(Pointer(S)^, P^, L);
  2253.       Inc(P, L);
  2254.     end;
  2255.     P^ := #13;
  2256.     Inc(P);
  2257.     P^ := #10;
  2258.     Inc(P);
  2259.   end;
  2260. end;
  2261.  
  2262. function TStrings.GetValue(const Name: string): string;
  2263. var
  2264.   I: Integer;
  2265. begin
  2266.   I := IndexOfName(Name);
  2267.   if I >= 0 then
  2268.     Result := Copy(Get(I), Length(Name) + 2, MaxInt) else
  2269.     Result := '';
  2270. end;
  2271.  
  2272. function TStrings.IndexOf(const S: string): Integer;
  2273. begin
  2274.   for Result := 0 to GetCount - 1 do
  2275.     if AnsiCompareText(Get(Result), S) = 0 then Exit;
  2276.   Result := -1;
  2277. end;
  2278.  
  2279. function TStrings.IndexOfName(const Name: string): Integer;
  2280. var
  2281.   P: Integer;
  2282.   S: string;
  2283. begin
  2284.   for Result := 0 to GetCount - 1 do
  2285.   begin
  2286.     S := Get(Result);
  2287.     P := AnsiPos('=', S);
  2288.     if (P <> 0) and (AnsiCompareText(Copy(S, 1, P - 1), Name) = 0) then Exit;
  2289.   end;
  2290.   Result := -1;
  2291. end;
  2292.  
  2293. function TStrings.IndexOfObject(AObject: TObject): Integer;
  2294. begin
  2295.   for Result := 0 to GetCount - 1 do
  2296.     if GetObject(Result) = AObject then Exit;
  2297.   Result := -1;
  2298. end;
  2299.  
  2300. procedure TStrings.InsertObject(Index: Integer; const S: string;
  2301.   AObject: TObject);
  2302. begin
  2303.   Insert(Index, S);
  2304.   PutObject(Index, AObject);
  2305. end;
  2306.  
  2307. procedure TStrings.LoadFromFile(const FileName: string);
  2308. var
  2309.   Stream: TStream;
  2310. begin
  2311.   Stream := TFileStream.Create(FileName, fmOpenRead);
  2312.   try
  2313.     LoadFromStream(Stream);
  2314.   finally
  2315.     Stream.Free;
  2316.   end;
  2317. end;
  2318.  
  2319. procedure TStrings.LoadFromStream(Stream: TStream);
  2320. var
  2321.   Size: Integer;
  2322.   S: string;
  2323. begin
  2324.   BeginUpdate;
  2325.   try
  2326.     Size := Stream.Size - Stream.Position;
  2327.     SetString(S, nil, Size);
  2328.     Stream.Read(Pointer(S)^, Size);
  2329.     SetTextStr(S);
  2330.   finally
  2331.     EndUpdate;
  2332.   end;
  2333. end;
  2334.  
  2335. procedure TStrings.Move(CurIndex, NewIndex: Integer);
  2336. var
  2337.   TempObject: TObject;
  2338.   TempString: string;
  2339. begin
  2340.   if CurIndex <> NewIndex then
  2341.   begin
  2342.     BeginUpdate;
  2343.     try
  2344.       TempString := Get(CurIndex);
  2345.       TempObject := GetObject(CurIndex);
  2346.       Delete(CurIndex);
  2347.       InsertObject(NewIndex, TempString, TempObject);
  2348.     finally
  2349.       EndUpdate;
  2350.     end;
  2351.   end;
  2352. end;
  2353.  
  2354. procedure TStrings.Put(Index: Integer; const S: string);
  2355. var
  2356.   TempObject: TObject;
  2357. begin
  2358.   TempObject := GetObject(Index);
  2359.   Delete(Index);
  2360.   InsertObject(Index, S, TempObject);
  2361. end;
  2362.  
  2363. procedure TStrings.PutObject(Index: Integer; AObject: TObject);
  2364. begin
  2365. end;
  2366.  
  2367. procedure TStrings.ReadData(Reader: TReader);
  2368. begin
  2369.   Reader.ReadListBegin;
  2370.   BeginUpdate;
  2371.   try
  2372.     Clear;
  2373.     while not Reader.EndOfList do Add(Reader.ReadString);
  2374.   finally
  2375.     EndUpdate;
  2376.   end;
  2377.   Reader.ReadListEnd;
  2378. end;
  2379.  
  2380. procedure TStrings.SaveToFile(const FileName: string);
  2381. var
  2382.   Stream: TStream;
  2383. begin
  2384.   Stream := TFileStream.Create(FileName, fmCreate);
  2385.   try
  2386.     SaveToStream(Stream);
  2387.   finally
  2388.     Stream.Free;
  2389.   end;
  2390. end;
  2391.  
  2392. procedure TStrings.SaveToStream(Stream: TStream);
  2393. var
  2394.   S: string;
  2395. begin
  2396.   S := GetTextStr;
  2397.   Stream.WriteBuffer(Pointer(S)^, Length(S));
  2398. end;
  2399.  
  2400. procedure TStrings.SetCapacity(NewCapacity: Integer);
  2401. begin
  2402.   // do nothing - descendants may optionally implement this method
  2403. end;
  2404.  
  2405. procedure TStrings.SetCommaText(const Value: string);
  2406. var
  2407.   P, P1: PChar;
  2408.   S: string;
  2409. begin
  2410.   BeginUpdate;
  2411.   try
  2412.     Clear;
  2413.     P := PChar(Value);
  2414.     while P^ in [#1..' '] do P := CharNext(P);
  2415.     while P^ <> #0 do
  2416.     begin
  2417.       if P^ = '"' then
  2418.         S := AnsiExtractQuotedStr(P, '"')
  2419.       else
  2420.       begin
  2421.         P1 := P;
  2422.         while (P^ > ' ') and (P^ <> ',') do P := CharNext(P);
  2423.         SetString(S, P1, P - P1);
  2424.       end;
  2425.       Add(S);
  2426.       while P^ in [#1..' '] do P := CharNext(P);
  2427.       if P^ = ',' then
  2428.         repeat
  2429.           P := CharNext(P);
  2430.         until not (P^ in [#1..' ']);
  2431.     end;
  2432.   finally
  2433.     EndUpdate;
  2434.   end;
  2435. end;
  2436.  
  2437. procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
  2438. begin
  2439.   if FAdapter <> nil then FAdapter.ReleaseStrings;
  2440.   FAdapter := Value;
  2441.   if FAdapter <> nil then FAdapter.ReferenceStrings(Self);
  2442. end;
  2443.  
  2444. procedure TStrings.SetText(Text: PChar);
  2445. begin
  2446.   SetTextStr(Text);
  2447. end;
  2448.  
  2449. procedure TStrings.SetTextStr(const Value: string);
  2450. var
  2451.   P, Start: PChar;
  2452.   S: string;
  2453. begin
  2454.   BeginUpdate;
  2455.   try
  2456.     Clear;
  2457.     P := Pointer(Value);
  2458.     if P <> nil then
  2459.       while P^ <> #0 do
  2460.       begin
  2461.         Start := P;
  2462.         while not (P^ in [#0, #10, #13]) do Inc(P);
  2463.         SetString(S, Start, P - Start);
  2464.         Add(S);
  2465.         if P^ = #13 then Inc(P);
  2466.         if P^ = #10 then Inc(P);
  2467.       end;
  2468.   finally
  2469.     EndUpdate;
  2470.   end;
  2471. end;
  2472.  
  2473. procedure TStrings.SetUpdateState(Updating: Boolean);
  2474. begin
  2475. end;
  2476.  
  2477. procedure TStrings.SetValue(const Name, Value: string);
  2478. var
  2479.   I: Integer;
  2480. begin
  2481.   I := IndexOfName(Name);
  2482.   if Value <> '' then
  2483.   begin
  2484.     if I < 0 then I := Add('');
  2485.     Put(I, Name + '=' + Value);
  2486.   end else
  2487.   begin
  2488.     if I >= 0 then Delete(I);
  2489.   end;
  2490. end;
  2491.  
  2492. procedure TStrings.WriteData(Writer: TWriter);
  2493. var
  2494.   I: Integer;
  2495. begin
  2496.   Writer.WriteListBegin;
  2497.   for I := 0 to Count - 1 do Writer.WriteString(Get(I));
  2498.   Writer.WriteListEnd;
  2499. end;
  2500.  
  2501. { TStringList }
  2502.  
  2503. destructor TStringList.Destroy;
  2504. begin
  2505.   FOnChange := nil;
  2506.   FOnChanging := nil;
  2507.   inherited Destroy;
  2508.   if FCount <> 0 then Finalize(FList^[0], FCount);
  2509.   FCount := 0;
  2510.   SetCapacity(0);
  2511. end;
  2512.  
  2513. function TStringList.Add(const S: string): Integer;
  2514. begin
  2515.   if not Sorted then
  2516.     Result := FCount
  2517.   else
  2518.     if Find(S, Result) then
  2519.       case Duplicates of
  2520.         dupIgnore: Exit;
  2521.         dupError: Error(SDuplicateString, 0);
  2522.       end;
  2523.   InsertItem(Result, S);
  2524. end;
  2525.  
  2526. procedure TStringList.Changed;
  2527. begin
  2528.   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
  2529. end;
  2530.  
  2531. procedure TStringList.Changing;
  2532. begin
  2533.   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
  2534. end;
  2535.  
  2536. procedure TStringList.Clear;
  2537. begin
  2538.   if FCount <> 0 then
  2539.   begin
  2540.     Changing;
  2541.     Finalize(FList^[0], FCount);
  2542.     FCount := 0;
  2543.     SetCapacity(0);
  2544.     Changed;
  2545.   end;
  2546. end;
  2547.  
  2548. procedure TStringList.Delete(Index: Integer);
  2549. begin
  2550.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2551.   Changing;
  2552.   Finalize(FList^[Index]);
  2553.   Dec(FCount);
  2554.   if Index < FCount then
  2555.     System.Move(FList^[Index + 1], FList^[Index],
  2556.       (FCount - Index) * SizeOf(TStringItem));
  2557.   Changed;
  2558. end;
  2559.  
  2560. procedure TStringList.Exchange(Index1, Index2: Integer);
  2561. begin
  2562.   if (Index1 < 0) or (Index1 >= FCount) then Error(SListIndexError, Index1);
  2563.   if (Index2 < 0) or (Index2 >= FCount) then Error(SListIndexError, Index2);
  2564.   Changing;
  2565.   ExchangeItems(Index1, Index2);
  2566.   Changed;
  2567. end;
  2568.  
  2569. procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  2570. var
  2571.   Temp: Integer;
  2572.   Item1, Item2: PStringItem;
  2573. begin
  2574.   Item1 := @FList^[Index1];
  2575.   Item2 := @FList^[Index2];
  2576.   Temp := Integer(Item1^.FString);
  2577.   Integer(Item1^.FString) := Integer(Item2^.FString);
  2578.   Integer(Item2^.FString) := Temp;
  2579.   Temp := Integer(Item1^.FObject);
  2580.   Integer(Item1^.FObject) := Integer(Item2^.FObject);
  2581.   Integer(Item2^.FObject) := Temp;
  2582. end;
  2583.  
  2584. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  2585. var
  2586.   L, H, I, C: Integer;
  2587. begin
  2588.   Result := False;
  2589.   L := 0;
  2590.   H := FCount - 1;
  2591.   while L <= H do
  2592.   begin
  2593.     I := (L + H) shr 1;
  2594.     C := AnsiCompareText(FList^[I].FString, S);
  2595.     if C < 0 then L := I + 1 else
  2596.     begin
  2597.       H := I - 1;
  2598.       if C = 0 then
  2599.       begin
  2600.         Result := True;
  2601.         if Duplicates <> dupAccept then L := I;
  2602.       end;
  2603.     end;
  2604.   end;
  2605.   Index := L;
  2606. end;
  2607.  
  2608. function TStringList.Get(Index: Integer): string;
  2609. begin
  2610.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2611.   Result := FList^[Index].FString;
  2612. end;
  2613.  
  2614. function TStringList.GetCapacity: Integer;
  2615. begin
  2616.   Result := FCapacity;
  2617. end;
  2618.  
  2619. function TStringList.GetCount: Integer;
  2620. begin
  2621.   Result := FCount;
  2622. end;
  2623.  
  2624. function TStringList.GetObject(Index: Integer): TObject;
  2625. begin
  2626.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2627.   Result := FList^[Index].FObject;
  2628. end;
  2629.  
  2630. procedure TStringList.Grow;
  2631. var
  2632.   Delta: Integer;
  2633. begin
  2634.   if FCapacity > 64 then Delta := FCapacity div 4 else
  2635.     if FCapacity > 8 then Delta := 16 else
  2636.       Delta := 4;
  2637.   SetCapacity(FCapacity + Delta);
  2638. end;
  2639.  
  2640. function TStringList.IndexOf(const S: string): Integer;
  2641. begin
  2642.   if not Sorted then Result := inherited IndexOf(S) else
  2643.     if not Find(S, Result) then Result := -1;
  2644. end;
  2645.  
  2646. procedure TStringList.Insert(Index: Integer; const S: string);
  2647. begin
  2648.   if Sorted then Error(SSortedListError, 0);
  2649.   if (Index < 0) or (Index > FCount) then Error(SListIndexError, Index);
  2650.   InsertItem(Index, S);
  2651. end;
  2652.  
  2653. procedure TStringList.InsertItem(Index: Integer; const S: string);
  2654. begin
  2655.   Changing;
  2656.   if FCount = FCapacity then Grow;
  2657.   if Index < FCount then
  2658.     System.Move(FList^[Index], FList^[Index + 1],
  2659.       (FCount - Index) * SizeOf(TStringItem));
  2660.   with FList^[Index] do
  2661.   begin
  2662.     Pointer(FString) := nil;
  2663.     FObject := nil;
  2664.     FString := S;
  2665.   end;
  2666.   Inc(FCount);
  2667.   Changed;
  2668. end;
  2669.  
  2670. procedure TStringList.Put(Index: Integer; const S: string);
  2671. begin
  2672.   if Sorted then Error(SSortedListError, 0);
  2673.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2674.   Changing;
  2675.   FList^[Index].FString := S;
  2676.   Changed;
  2677. end;
  2678.  
  2679. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  2680. begin
  2681.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2682.   Changing;
  2683.   FList^[Index].FObject := AObject;
  2684.   Changed;
  2685. end;
  2686.  
  2687. procedure TStringList.QuickSort(L, R: Integer);
  2688. var
  2689.   I, J: Integer;
  2690.   P: string;
  2691. begin
  2692.   repeat
  2693.     I := L;
  2694.     J := R;
  2695.     P := FList^[(L + R) shr 1].FString;
  2696.     repeat
  2697.       while AnsiCompareText(FList^[I].FString, P) < 0 do Inc(I);
  2698.       while AnsiCompareText(FList^[J].FString, P) > 0 do Dec(J);
  2699.       if I <= J then
  2700.       begin
  2701.         ExchangeItems(I, J);
  2702.         Inc(I);
  2703.         Dec(J);
  2704.       end;
  2705.     until I > J;
  2706.     if L < J then QuickSort(L, J);
  2707.     L := I;
  2708.   until I >= R;
  2709. end;
  2710.  
  2711. procedure TStringList.SetCapacity(NewCapacity: Integer);
  2712. begin
  2713.   ReallocMem(FList, NewCapacity * SizeOf(TStringItem));
  2714.   FCapacity := NewCapacity;
  2715. end;
  2716.  
  2717. procedure TStringList.SetSorted(Value: Boolean);
  2718. begin
  2719.   if FSorted <> Value then
  2720.   begin
  2721.     if Value then Sort;
  2722.     FSorted := Value;
  2723.   end;
  2724. end;
  2725.  
  2726. procedure TStringList.SetUpdateState(Updating: Boolean);
  2727. begin
  2728.   if Updating then Changing else Changed;
  2729. end;
  2730.  
  2731. procedure TStringList.Sort;
  2732. begin
  2733.   if not Sorted and (FCount > 1) then
  2734.   begin
  2735.     Changing;
  2736.     QuickSort(0, FCount - 1);
  2737.     Changed;
  2738.   end;
  2739. end;
  2740.  
  2741. { TStream }
  2742.  
  2743. function TStream.GetPosition: Longint;
  2744. begin
  2745.   Result := Seek(0, 1);
  2746. end;
  2747.  
  2748. procedure TStream.SetPosition(Pos: Longint);
  2749. begin
  2750.   Seek(Pos, 0);
  2751. end;
  2752.  
  2753. function TStream.GetSize: Longint;
  2754. var
  2755.   Pos: Longint;
  2756. begin
  2757.   Pos := Seek(0, 1);
  2758.   Result := Seek(0, 2);
  2759.   Seek(Pos, 0);
  2760. end;
  2761.  
  2762. procedure TStream.SetSize(NewSize: Longint);
  2763. begin
  2764.   // default = do nothing  (read-only streams, etc)
  2765. end;
  2766.  
  2767. procedure TStream.ReadBuffer(var Buffer; Count: Longint);
  2768. begin
  2769.   if (Count <> 0) and (Read(Buffer, Count) <> Count) then
  2770.     raise EReadError.Create(SReadError);
  2771. end;
  2772.  
  2773. procedure TStream.WriteBuffer(const Buffer; Count: Longint);
  2774. begin
  2775.   if (Count <> 0) and (Write(Buffer, Count) <> Count) then
  2776.     raise EWriteError.Create(SWriteError);
  2777. end;
  2778.  
  2779. function TStream.CopyFrom(Source: TStream; Count: Longint): Longint;
  2780. const
  2781.   MaxBufSize = $F000;
  2782. var
  2783.   BufSize, N: Integer;
  2784.   Buffer: PChar;
  2785. begin
  2786.   if Count = 0 then
  2787.   begin
  2788.     Source.Position := 0;
  2789.     Count := Source.Size;
  2790.   end;
  2791.   Result := Count;
  2792.   if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
  2793.   GetMem(Buffer, BufSize);
  2794.   try
  2795.     while Count <> 0 do
  2796.     begin
  2797.       if Count > BufSize then N := BufSize else N := Count;
  2798.       Source.ReadBuffer(Buffer^, N);
  2799.       WriteBuffer(Buffer^, N);
  2800.       Dec(Count, N);
  2801.     end;
  2802.   finally
  2803.     FreeMem(Buffer, BufSize);
  2804.   end;
  2805. end;
  2806.  
  2807. function TStream.ReadComponent(Instance: TComponent): TComponent;
  2808. var
  2809.   Reader: TReader;
  2810. begin
  2811.   Reader := TReader.Create(Self, 4096);
  2812.   try
  2813.     Result := Reader.ReadRootComponent(Instance);
  2814.   finally
  2815.     Reader.Free;
  2816.   end;
  2817. end;
  2818.  
  2819. procedure TStream.WriteComponent(Instance: TComponent);
  2820. begin
  2821.   WriteDescendent(Instance, nil);
  2822. end;
  2823.  
  2824. procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
  2825. var
  2826.   Writer: TWriter;
  2827. begin
  2828.   Writer := TWriter.Create(Self, 4096);
  2829.   try
  2830.     Writer.WriteDescendent(Instance, Ancestor);
  2831.   finally
  2832.     Writer.Free;
  2833.   end;
  2834. end;
  2835.  
  2836. function TStream.ReadComponentRes(Instance: TComponent): TComponent;
  2837. begin
  2838.   ReadResHeader;
  2839.   Result := ReadComponent(Instance);
  2840. end;
  2841.  
  2842. procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
  2843. begin
  2844.   WriteDescendentRes(ResName, Instance, nil);
  2845. end;
  2846.  
  2847. procedure TStream.WriteDescendentRes(const ResName: string; Instance,
  2848.   Ancestor: TComponent);
  2849. var
  2850.   HeaderSize: Integer;
  2851.   Origin, ImageSize: Longint;
  2852.   Header: array[0..79] of Char;
  2853. begin
  2854.   Byte((@Header[0])^) := $FF;
  2855.   Word((@Header[1])^) := 10;
  2856.   HeaderSize := StrLen(StrUpper(StrPLCopy(@Header[3], ResName, 63))) + 10;
  2857.   Word((@Header[HeaderSize - 6])^) := $1030;
  2858.   Longint((@Header[HeaderSize - 4])^) := 0;
  2859.   WriteBuffer(Header, HeaderSize);
  2860.   Origin := Position;
  2861.   WriteDescendent(Instance, Ancestor);
  2862.   ImageSize := Position - Origin;
  2863.   Position := Origin - 4;
  2864.   WriteBuffer(ImageSize, SizeOf(Longint));
  2865.   Position := Origin + ImageSize;
  2866. end;
  2867.  
  2868. procedure TStream.ReadResHeader;
  2869. var
  2870.   ReadCount: Longint;
  2871.   Header: array[0..79] of Char;
  2872. begin
  2873.   FillChar(Header, SizeOf(Header), 0);
  2874.   ReadCount := Read(Header, SizeOf(Header) - 1);
  2875.   if (Byte((@Header[0])^) = $FF) and (Word((@Header[1])^) = 10) then
  2876.     Seek(StrLen(Header + 3) + 10 - ReadCount, 1)
  2877.   else
  2878.     raise EInvalidImage.Create(SInvalidImage);
  2879. end;
  2880.  
  2881. { THandleStream }
  2882.  
  2883. constructor THandleStream.Create(AHandle: Integer);
  2884. begin
  2885.   FHandle := AHandle;
  2886. end;
  2887.  
  2888. function THandleStream.Read(var Buffer; Count: Longint): Longint;
  2889. begin
  2890.   Result := FileRead(FHandle, Buffer, Count);
  2891.   if Result = -1 then Result := 0;
  2892. end;
  2893.  
  2894. function THandleStream.Write(const Buffer; Count: Longint): Longint;
  2895. begin
  2896.   Result := FileWrite(FHandle, Buffer, Count);
  2897.   if Result = -1 then Result := 0;
  2898. end;
  2899.  
  2900. function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
  2901. begin
  2902.   Result := FileSeek(FHandle, Offset, Origin);
  2903. end;
  2904.  
  2905. procedure THandleStream.SetSize(NewSize: Longint);
  2906. begin
  2907.   Seek(NewSize, soFromBeginning);
  2908.   Win32Check(SetEndOfFile(FHandle));
  2909. end;
  2910.  
  2911. { TFileStream }
  2912.  
  2913. constructor TFileStream.Create(const FileName: string; Mode: Word);
  2914. begin
  2915.   if Mode = fmCreate then
  2916.   begin
  2917.     FHandle := FileCreate(FileName);
  2918.     if FHandle < 0 then
  2919.       raise EFCreateError.CreateFmt(SFCreateError, [FileName]);
  2920.   end else
  2921.   begin
  2922.     FHandle := FileOpen(FileName, Mode);
  2923.     if FHandle < 0 then
  2924.       raise EFOpenError.CreateFmt(SFOpenError, [FileName]);
  2925.   end;
  2926. end;
  2927.  
  2928. destructor TFileStream.Destroy;
  2929. begin
  2930.   if FHandle >= 0 then FileClose(FHandle);
  2931. end;
  2932.  
  2933.  
  2934. { TCustomMemoryStream }
  2935.  
  2936. procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Longint);
  2937. begin
  2938.   FMemory := Ptr;
  2939.   FSize := Size;
  2940. end;
  2941.  
  2942. function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
  2943. begin
  2944.   if (FPosition >= 0) and (Count >= 0) then
  2945.   begin
  2946.     Result := FSize - FPosition;
  2947.     if Result > 0 then
  2948.     begin
  2949.       if Result > Count then Result := Count;
  2950.       Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
  2951.       Inc(FPosition, Result);
  2952.       Exit;
  2953.     end;
  2954.   end;
  2955.   Result := 0;
  2956. end;
  2957.  
  2958. function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
  2959. begin
  2960.   case Origin of
  2961.     0: FPosition := Offset;
  2962.     1: Inc(FPosition, Offset);
  2963.     2: FPosition := FSize + Offset;
  2964.   end;
  2965.   Result := FPosition;
  2966. end;
  2967.  
  2968. procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
  2969. begin
  2970.   if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
  2971. end;
  2972.  
  2973. procedure TCustomMemoryStream.SaveToFile(const FileName: string);
  2974. var
  2975.   Stream: TStream;
  2976. begin
  2977.   Stream := TFileStream.Create(FileName, fmCreate);
  2978.   try
  2979.     SaveToStream(Stream);
  2980.   finally
  2981.     Stream.Free;
  2982.   end;
  2983. end;
  2984.  
  2985. { TMemoryStream }
  2986.  
  2987. const
  2988.   MemoryDelta = $2000; { Must be a power of 2 }
  2989.  
  2990. destructor TMemoryStream.Destroy;
  2991. begin
  2992.   Clear;
  2993.   inherited Destroy;
  2994. end;
  2995.  
  2996. procedure TMemoryStream.Clear;
  2997. begin
  2998.   SetCapacity(0);
  2999.   FSize := 0;
  3000.   FPosition := 0;
  3001. end;
  3002.  
  3003. procedure TMemoryStream.LoadFromStream(Stream: TStream);
  3004. var
  3005.   Count: Longint;
  3006. begin
  3007.   Stream.Position := 0;
  3008.   Count := Stream.Size;
  3009.   SetSize(Count);
  3010.   if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
  3011. end;
  3012.  
  3013. procedure TMemoryStream.LoadFromFile(const FileName: string);
  3014. var
  3015.   Stream: TStream;
  3016. begin
  3017.   Stream := TFileStream.Create(FileName, fmOpenRead);
  3018.   try
  3019.     LoadFromStream(Stream);
  3020.   finally
  3021.     Stream.Free;
  3022.   end;
  3023. end;
  3024.  
  3025. procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
  3026. begin
  3027.   SetPointer(Realloc(NewCapacity), FSize);
  3028.   FCapacity := NewCapacity;
  3029. end;
  3030.  
  3031. procedure TMemoryStream.SetSize(NewSize: Longint);
  3032. begin
  3033. //  Clear;
  3034.   if FPosition > NewSize then Seek(0, soFromEnd);
  3035.   SetCapacity(NewSize);
  3036.   FSize := NewSize;
  3037. end;
  3038.  
  3039. function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
  3040. begin
  3041.   if NewCapacity > 0 then
  3042.     NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  3043.   Result := Memory;
  3044.   if NewCapacity <> FCapacity then
  3045.   begin
  3046.     if NewCapacity = 0 then
  3047.     begin
  3048.       GlobalFreePtr(Memory);
  3049.       Result := nil;
  3050.     end else
  3051.     begin
  3052.       if Capacity = 0 then
  3053.         Result := GlobalAllocPtr(HeapAllocFlags, NewCapacity)
  3054.       else
  3055.         Result := GlobalReallocPtr(Memory, NewCapacity, HeapAllocFlags);
  3056.       if Result = nil then raise EStreamError.Create(SMemoryStreamError);
  3057.     end;
  3058.   end;
  3059. end;
  3060.  
  3061. function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
  3062. var
  3063.   Pos: Longint;
  3064. begin
  3065.   if (FPosition >= 0) and (Count >= 0) then
  3066.   begin
  3067.     Pos := FPosition + Count;
  3068.     if Pos > 0 then
  3069.     begin
  3070.       if Pos > FSize then
  3071.       begin
  3072.         if Pos > FCapacity then
  3073.           SetCapacity(Pos);
  3074.         FSize := Pos;
  3075.       end;
  3076.       System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
  3077.       FPosition := Pos;
  3078.       Result := Count;
  3079.       Exit;
  3080.     end;
  3081.   end;
  3082.   Result := 0;
  3083. end;
  3084.  
  3085. { TStringStream }
  3086.  
  3087. constructor TStringStream.Create(const AString: string);
  3088. begin
  3089.   inherited Create;
  3090.   FDataString := AString;
  3091. end;
  3092.  
  3093. function TStringStream.Read(var Buffer; Count: Longint): Longint;
  3094. begin
  3095.   Result := Length(FDataString) - FPosition;
  3096.   if Result > Count then Result := Count;
  3097.   Move(PChar(@FDataString[FPosition + 1])^, Buffer, Result);
  3098.   Inc(FPosition, Result);
  3099. end;
  3100.  
  3101. function TStringStream.Write(const Buffer; Count: Longint): Longint;
  3102. begin
  3103.   Result := Count;
  3104.   SetLength(FDataString, (FPosition + Result));
  3105.   Move(Buffer, PChar(@FDataString[FPosition + 1])^, Result);
  3106.   Inc(FPosition, Result);
  3107. end;
  3108.  
  3109. function TStringStream.Seek(Offset: Longint; Origin: Word): Longint;
  3110. begin
  3111.   case Origin of
  3112.     soFromBeginning: FPosition := Offset;
  3113.     soFromCurrent: FPosition := FPosition + Offset;
  3114.     soFromEnd: FPosition := Length(FDataString) - Offset;
  3115.   end;
  3116.   if FPosition > Length(FDataString) then
  3117.     FPosition := Length(FDataString)
  3118.   else if FPosition < 0 then FPosition := 0;
  3119.   Result := FPosition;
  3120. end;
  3121.  
  3122. function TStringStream.ReadString(Count: Longint): string;
  3123. var
  3124.   Len: Integer;
  3125. begin
  3126.   Len := Length(FDataString) - FPosition;
  3127.   if Len > Count then Len := Count;
  3128.   SetString(Result, PChar(@FDataString[FPosition + 1]), Len);
  3129.   Inc(FPosition, Len);
  3130. end;
  3131.  
  3132. procedure TStringStream.WriteString(const AString: string);
  3133. begin
  3134.   Write(PChar(AString)^, Length(AString));
  3135. end;
  3136.  
  3137. procedure TStringStream.SetSize(NewSize: Longint);
  3138. begin
  3139.   SetLength(FDataString, NewSize);
  3140.   if FPosition > NewSize then FPosition := NewSize;
  3141. end;
  3142.  
  3143. { TResourceStream }
  3144.  
  3145. constructor TResourceStream.Create(Instance: THandle; const ResName: string;
  3146.   ResType: PChar);
  3147. begin
  3148.   inherited Create;
  3149.   Initialize(Instance, PChar(ResName), ResType);
  3150. end;
  3151.  
  3152. constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
  3153.   ResType: PChar);
  3154. begin
  3155.   inherited Create;
  3156.   Initialize(Instance, PChar(ResID), ResType);
  3157. end;
  3158.  
  3159. procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
  3160.  
  3161.   procedure Error;
  3162.   begin
  3163.     raise EResNotFound.Create(Format(SResNotFound, [Name]));
  3164.   end;
  3165.  
  3166. begin
  3167.   HResInfo := FindResource(Instance, Name, ResType);
  3168.   if HResInfo = 0 then Error;
  3169.   HGlobal := LoadResource(Instance, HResInfo);
  3170.   if HGlobal = 0 then Error;
  3171.   SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
  3172. end;
  3173.  
  3174. destructor TResourceStream.Destroy;
  3175. begin
  3176.   UnlockResource(HGlobal);
  3177.   FreeResource(HResInfo);
  3178.   inherited Destroy;
  3179. end;
  3180.  
  3181. function TResourceStream.Write(const Buffer; Count: Longint): Longint;
  3182. begin
  3183.   raise EStreamError.Create(SCantWriteResourceStreamError);
  3184. end;
  3185.  
  3186. { TFiler }
  3187.  
  3188. constructor TFiler.Create(Stream: TStream; BufSize: Integer);
  3189. begin
  3190.   FStream := Stream;
  3191.   GetMem(FBuffer, BufSize);
  3192.   FBufSize := BufSize;
  3193. end;
  3194.  
  3195. destructor TFiler.Destroy;
  3196. begin
  3197.   if FBuffer <> nil then FreeMem(FBuffer, FBufSize);
  3198. end;
  3199.  
  3200. { TPropFixup }
  3201.  
  3202. type
  3203.   TPropFixup = class
  3204.     FInstance: TPersistent;
  3205.     FInstanceRoot: TComponent;
  3206.     FPropInfo: PPropInfo;
  3207.     FRootName: string;
  3208.     FName: string;
  3209.     constructor Create(Instance: TPersistent; InstanceRoot: TComponent;
  3210.       PropInfo: PPropInfo; const RootName, Name: string);
  3211.   end;
  3212.  
  3213. var
  3214.   GlobalFixupList: TList;
  3215.  
  3216. constructor TPropFixup.Create(Instance: TPersistent; InstanceRoot: TComponent;
  3217.   PropInfo: PPropInfo; const RootName, Name: string);
  3218. begin
  3219.   FInstance := Instance;
  3220.   FInstanceRoot := InstanceRoot;
  3221.   FPropInfo := PropInfo;
  3222.   FRootName := RootName;
  3223.   FName := Name;
  3224. end;
  3225.  
  3226. procedure GlobalFixupReferences;
  3227. var
  3228.   FinishedList: TList;
  3229.   NotFinishedList: TList;
  3230.   I: Integer;
  3231.   Root: TComponent;
  3232.   Instance: TPersistent;
  3233.  
  3234.   procedure AddFinished(Instance: TPersistent);
  3235.   begin
  3236.     if (FinishedList.IndexOf(Instance) < 0) and
  3237.       (NotFinishedList.IndexOf(Instance) >= 0) then
  3238.       FinishedList.Add(Instance);
  3239.   end;
  3240.  
  3241.   procedure AddNotFinished(Instance: TPersistent);
  3242.   var
  3243.     Index: Integer;
  3244.   begin
  3245.     Index := FinishedList.IndexOf(Instance);
  3246.     if Index <> -1 then FinishedList.Delete(Index);
  3247.     if NotFinishedList.IndexOf(Instance) < 0 then
  3248.       NotFinishedList.Add(Instance);
  3249.   end;
  3250.  
  3251. begin
  3252.   if Assigned(FindGlobalComponent) and (GlobalFixupList.Count > 0) then
  3253.   begin
  3254.     FinishedList := TList.Create;
  3255.     try
  3256.       NotFinishedList := TList.Create;
  3257.       try
  3258.         I := 0;
  3259.         while I < GlobalFixupList.Count do
  3260.           with TPropFixup(GlobalFixupList[I]) do
  3261.           begin
  3262.             Root := FindGlobalComponent(FRootName);
  3263.             if (Root <> nil) or (GetOrdProp(FInstance, FPropInfo) <> 0) then
  3264.             begin
  3265.               if Root <> nil then
  3266.                 SetOrdProp(FInstance, FPropInfo,
  3267.                   Longint(Root.FindComponent(FName)));
  3268.               AddFinished(FInstance);
  3269.               GlobalFixupList.Delete(I);
  3270.               Free;
  3271.             end else
  3272.             begin
  3273.               AddNotFinished(FInstance);
  3274.               Inc(I);
  3275.             end;
  3276.           end;
  3277.       finally
  3278.         NotFinishedList.Free;
  3279.       end;
  3280.       for I := 0 to FinishedList.Count - 1 do
  3281.       begin
  3282.         Instance := FinishedList[I];
  3283.         if Instance is TComponent then
  3284.           Exclude(TComponent(Instance).FComponentState, csFixups);
  3285.       end;
  3286.     finally
  3287.       FinishedList.Free;
  3288.     end;
  3289.   end;
  3290. end;
  3291.  
  3292. function NameInStrings(Strings: TStrings; const Name: string): Boolean;
  3293. var
  3294.   I: Integer;
  3295. begin
  3296.   Result := True;
  3297.   for I := 0 to Strings.Count - 1 do
  3298.     if CompareText(Name, Strings[I]) = 0 then Exit;
  3299.   Result := False;
  3300. end;
  3301.  
  3302. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  3303. var
  3304.   I: Integer;
  3305.   Fixup: TPropFixup;
  3306. begin
  3307.   for I := 0 to GlobalFixupList.Count - 1 do
  3308.   begin
  3309.     Fixup := GlobalFixupList[I];
  3310.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  3311.       not NameInStrings(Names, Fixup.FRootName) then
  3312.       Names.Add(Fixup.FRootName);
  3313.   end;
  3314. end;
  3315.  
  3316. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  3317.   NewRootName: string);
  3318. var
  3319.   I: Integer;
  3320.   Fixup: TPropFixup;
  3321. begin
  3322.   for I := 0 to GlobalFixupList.Count - 1 do
  3323.   begin
  3324.     Fixup := GlobalFixupList[I];
  3325.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  3326.       (CompareText(OldRootName, Fixup.FRootName) = 0) then
  3327.       Fixup.FRootName := NewRootName;
  3328.   end;
  3329.   GlobalFixupReferences;
  3330. end;
  3331.  
  3332. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  3333. var
  3334.   I: Integer;
  3335.   Fixup: TPropFixup;
  3336. begin
  3337.   for I := GlobalFixupList.Count - 1 downto 0 do
  3338.   begin
  3339.     Fixup := GlobalFixupList[I];
  3340.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  3341.       ((RootName = '') or (CompareText(RootName, Fixup.FRootName) = 0)) then
  3342.     begin
  3343.       GlobalFixupList.Delete(I);
  3344.       Fixup.Free;
  3345.     end;
  3346.   end;
  3347. end;
  3348.  
  3349. procedure GetFixupInstanceNames(Root: TComponent;
  3350.   const ReferenceRootName: string; Names: TStrings);
  3351. var
  3352.   I: Integer;
  3353.   Fixup: TPropFixup;
  3354. begin
  3355.   for I := 0 to GlobalFixupList.Count - 1 do
  3356.   begin
  3357.     Fixup := GlobalFixupList[I];
  3358.     if (Fixup.FInstanceRoot = Root) and
  3359.       (CompareText(ReferenceRootName, Fixup.FRootName) = 0) and
  3360.       not NameInStrings(Names, Fixup.FName) then
  3361.       Names.Add(Fixup.FName);
  3362.   end;
  3363. end;
  3364.  
  3365. { TReader }
  3366.  
  3367. procedure ReadError(const Ident: string);
  3368. begin
  3369.   raise EReadError.Create(Ident);
  3370. end;
  3371.  
  3372. procedure PropValueError;
  3373. begin
  3374.   ReadError(SInvalidPropertyValue);
  3375. end;
  3376.  
  3377. procedure PropertyNotFound;
  3378. begin
  3379.   ReadError(SUnknownProperty);
  3380. end;
  3381.  
  3382. function EnumValue(EnumType: PTypeInfo; const EnumName: string): Integer;
  3383. begin
  3384.   Result := GetEnumValue(EnumType, EnumName);
  3385.   if Result = -1 then PropValueError;
  3386. end;
  3387.  
  3388. destructor TReader.Destroy;
  3389. begin
  3390.   FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), 1);
  3391.   inherited Destroy;
  3392. end;
  3393.  
  3394. procedure TReader.BeginReferences;
  3395. begin
  3396.   FLoaded := TList.Create;
  3397.   try
  3398.     FFixups := TList.Create;
  3399.   except
  3400.     FLoaded.Free;
  3401.     raise;
  3402.   end;
  3403. end;
  3404.  
  3405. procedure TReader.CheckValue(Value: TValueType);
  3406. begin
  3407.   if ReadValue <> Value then
  3408.   begin
  3409.     Dec(FBufPos);
  3410.     SkipValue;
  3411.     PropValueError;
  3412.   end;
  3413. end;
  3414.  
  3415. procedure TReader.DefineProperty(const Name: string;
  3416.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  3417. begin
  3418.   if (CompareText(Name, FPropName) = 0) and Assigned(ReadData) then
  3419.   begin
  3420.     ReadData(Self);
  3421.     FPropName := '';
  3422.   end;
  3423. end;
  3424.  
  3425. procedure TReader.DefineBinaryProperty(const Name: string;
  3426.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  3427. var
  3428.   Stream: TMemoryStream;
  3429.   Count: Longint;
  3430. begin
  3431.   if (CompareText(Name, FPropName) = 0) and Assigned(ReadData) then
  3432.   begin
  3433.     if ReadValue <> vaBinary then
  3434.     begin
  3435.       Dec(FBufPos);
  3436.       SkipValue;
  3437.       FCanHandleExcepts := True;
  3438.       PropValueError;
  3439.     end;
  3440.     Stream := TMemoryStream.Create;
  3441.     try
  3442.       Read(Count, SizeOf(Count));
  3443.       Stream.SetSize(Count);
  3444.       Read(Stream.Memory^, Count);
  3445.       FCanHandleExcepts := True;
  3446.       ReadData(Stream);
  3447.     finally
  3448.       Stream.Free;
  3449.     end;
  3450.     FPropName := '';
  3451.   end;
  3452. end;
  3453.  
  3454. function TReader.EndOfList: Boolean;
  3455. begin
  3456.   Result := ReadValue = vaNull;
  3457.   Dec(FBufPos);
  3458. end;
  3459.  
  3460. procedure TReader.EndReferences;
  3461. begin
  3462.   FreeFixups;
  3463.   FLoaded.Free;
  3464.   FLoaded := nil;
  3465. end;
  3466.  
  3467. function TReader.Error(const Message: string): Boolean;
  3468. begin
  3469.   Result := False;
  3470.   if Assigned(FOnError) then FOnError(Self, Message, Result);
  3471. end;
  3472.  
  3473. function TReader.FindMethod(Root: TComponent;
  3474.   const MethodName: string): Pointer;
  3475. var
  3476.   Error: Boolean;
  3477. begin
  3478.   Result := Root.MethodAddress(MethodName);
  3479.   Error := Result = nil;
  3480.   if Assigned(FOnFindMethod) then FOnFindMethod(Self, MethodName, Result, Error);
  3481.   if Error then PropValueError;
  3482. end;
  3483.  
  3484. procedure TReader.DoFixupReferences;
  3485. var
  3486.   I: Integer;
  3487.   CompName: string;
  3488. begin
  3489.   if FFixups <> nil then
  3490.     try
  3491.       for I := 0 to FFixups.Count - 1 do
  3492.         with TPropFixup(FFixups[I]) do
  3493.         begin
  3494.           CompName := FName;
  3495.           ReferenceName(CompName);
  3496.           SetOrdProp(FInstance, FPropInfo,
  3497.             Longint(FRoot.FindComponent(CompName)));
  3498.         end;
  3499.     finally
  3500.       FreeFixups;
  3501.     end;
  3502. end;
  3503.  
  3504. procedure TReader.FixupReferences;
  3505. var
  3506.   I: Integer;
  3507. begin
  3508.   DoFixupReferences;
  3509.   GlobalFixupReferences;
  3510.   for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  3511. end;
  3512.  
  3513. procedure TReader.FlushBuffer;
  3514. begin
  3515.   FStream.Position := Position;
  3516.   FBufPos := 0;
  3517.   FBufEnd := 0;
  3518. end;
  3519.  
  3520. procedure TReader.FreeFixups;
  3521. var
  3522.   I: Integer;
  3523. begin
  3524.   if FFixups <> nil then
  3525.   begin
  3526.     for I := 0 to FFixups.Count - 1 do TPropFixup(FFixups[I]).Free;
  3527.     FFixups.Free;
  3528.     FFixups := nil;
  3529.   end;
  3530. end;
  3531.  
  3532. function TReader.GetPosition: Longint;
  3533. begin
  3534.   Result := FStream.Position - (FBufEnd - FBufPos);
  3535. end;
  3536.  
  3537. function TReader.NextValue: TValueType;
  3538. begin
  3539.   Result := ReadValue;
  3540.   Dec(FBufPos);
  3541. end;
  3542.  
  3543. procedure TReader.PropertyError;
  3544. begin
  3545.   SkipValue;
  3546.   PropertyNotFound;
  3547. end;
  3548.  
  3549. procedure TReader.Read(var Buf; Count: Longint); assembler;
  3550. asm
  3551.         PUSH    ESI
  3552.         PUSH    EDI
  3553.         PUSH    EBX
  3554.         MOV     EDI,EDX
  3555.         MOV     EBX,ECX
  3556.         MOV     ESI,EAX
  3557.         JMP     @@6
  3558. @@1:    MOV     ECX,[ESI].TReader.FBufEnd
  3559.         SUB     ECX,[ESI].TReader.FBufPos
  3560.         JA      @@2
  3561.         MOV     EAX,ESI
  3562.         CALL    TReader.ReadBuffer
  3563.         MOV     ECX,[ESI].TReader.FBufEnd
  3564. @@2:    CMP     ECX,EBX
  3565.         JB      @@3
  3566.         MOV     ECX,EBX
  3567. @@3:    PUSH    ESI
  3568.         SUB     EBX,ECX
  3569.         MOV     EAX,[ESI].TReader.FBuffer
  3570.         ADD     EAX,[ESI].TReader.FBufPos
  3571.         ADD     [ESI].TReader.FBufPos,ECX
  3572.         MOV     ESI,EAX
  3573.         MOV     EDX,ECX
  3574.         SHR     ECX,2
  3575.         CLD
  3576.         REP     MOVSD
  3577.         MOV     ECX,EDX
  3578.         AND     ECX,3
  3579.         REP     MOVSB
  3580.         POP     ESI
  3581. @@6:    OR      EBX,EBX
  3582.         JNE     @@1
  3583.         POP     EBX
  3584.         POP     EDI
  3585.         POP     ESI
  3586. end;
  3587.  
  3588. procedure TReader.ReadBuffer;
  3589. begin
  3590.   FBufEnd := FStream.Read(FBuffer^, FBufSize);
  3591.   if FBufEnd = 0 then raise EReadError.Create(SReadError);
  3592.   FBufPos := 0;
  3593. end;
  3594.  
  3595. function TReader.ReadBoolean: Boolean;
  3596. begin
  3597.   Result := ReadValue = vaTrue;
  3598. end;
  3599.  
  3600. function TReader.ReadChar: Char;
  3601. begin
  3602.   CheckValue(vaString);
  3603.   Read(Result, 1);
  3604.   if Ord(Result) <> 1 then
  3605.   begin
  3606.     Dec(FBufPos);
  3607.     ReadStr;
  3608.     PropValueError;
  3609.   end;
  3610.   Read(Result, 1);
  3611. end;
  3612.  
  3613. procedure TReader.ReadCollection(Collection: TCollection);
  3614. var
  3615.   Item: TPersistent;
  3616.   Index: Integer;
  3617. begin
  3618.   Index := 0;
  3619.   Collection.BeginUpdate;
  3620.   try
  3621.     while not EndOfList do
  3622.     begin
  3623.       if NextValue in [vaInt8, vaInt16, vaInt32] then Index := ReadInteger;
  3624.       while Collection.Count <= Index do Collection.Add;
  3625.       Item := Collection.Items[Index];
  3626.       ReadListBegin;
  3627.       while not EndOfList do ReadProperty(Item);
  3628.       ReadListEnd;
  3629.       Inc(Index);
  3630.     end;
  3631.     ReadListEnd;
  3632.   finally
  3633.     Collection.EndUpdate;
  3634.   end;
  3635. end;
  3636.  
  3637. function TReader.ReadComponent(Component: TComponent): TComponent;
  3638. var
  3639.   CompClass, CompName: string;
  3640.   Flags: TFilerFlags;
  3641.   Position: Integer;
  3642.  
  3643.   function ComponentCreated: Boolean;
  3644.   begin
  3645.     Result := not (ffInherited in Flags) and (Component = nil);
  3646.   end;
  3647.  
  3648.   function Recover(var Component: TComponent): Boolean;
  3649.   begin
  3650.     Result := False;
  3651.     if not (ExceptObject is Exception) then Exit;
  3652.     if ComponentCreated then Component.Free;
  3653.     Component := nil;
  3654.     SkipComponent(False);
  3655.     Result := Error(Exception(ExceptObject).Message);
  3656.   end;
  3657.  
  3658.   procedure CreateComponent;
  3659.   begin
  3660.     try
  3661.       Result := TComponentClass(FindFieldClass(Root, CompClass)).Create(Owner);
  3662.       Include(Result.FComponentState, csLoading);
  3663.     except
  3664.       if not Recover(Result) then raise;
  3665.     end;
  3666.   end;
  3667.  
  3668.   procedure SetCompName;
  3669.   begin
  3670.     try
  3671.       Result.SetParentComponent(Parent);
  3672.       SetName(Result, CompName);
  3673.     except
  3674.       if not Recover(Result) then raise;
  3675.     end;
  3676.   end;
  3677.  
  3678.   procedure FindExistingComponent;
  3679.   begin
  3680.     try
  3681.       Result := Root.FindComponent(CompName);
  3682.       if Result = nil then
  3683.         raise EReadError.CreateFmt(SAncestorNotFound, [CompName]);
  3684.     except
  3685.       if not Recover(Result) then raise;
  3686.     end;
  3687.   end;
  3688.  
  3689. begin
  3690.   ReadPrefix(Flags, Position);
  3691.   CompClass := ReadStr;
  3692.   CompName := ReadStr;
  3693.   Result := Component;
  3694.   if Result = nil then
  3695.     if ffInherited in Flags then
  3696.       FindExistingComponent else
  3697.       CreateComponent;
  3698.   if Result <> nil then
  3699.     try
  3700.       Include(Result.FComponentState, csLoading);
  3701.       if not (ffInherited in Flags) then SetCompName;
  3702.       if Result = nil then Exit;
  3703.       Include(Result.FComponentState, csReading);
  3704.       Result.ReadState(Self);
  3705.       Exclude(Result.FComponentState, csReading);
  3706.       if ffChildPos in Flags then Parent.SetChildOrder(Result, Position);
  3707.       FLoaded.Add(Result);
  3708.     except
  3709.       if ComponentCreated then Result.Free;
  3710.       raise;
  3711.     end;
  3712. end;
  3713.  
  3714. procedure TReader.ReadData(Instance: TComponent);
  3715. begin
  3716.   if FFixups = nil then
  3717.   begin
  3718.     FFixups := TList.Create;
  3719.     try
  3720.       ReadDataInner(Instance);
  3721.       DoFixupReferences;
  3722.     finally
  3723.       FreeFixups;
  3724.     end;
  3725.   end else
  3726.     ReadDataInner(Instance);
  3727. end;
  3728.  
  3729. procedure TReader.ReadDataInner(Instance: TComponent);
  3730. var
  3731.   OldParent, OldOwner: TComponent;
  3732. begin
  3733.   while not EndOfList do ReadProperty(Instance);
  3734.   ReadListEnd;
  3735.   OldParent := Parent;
  3736.   OldOwner := Owner;
  3737.   Parent := Instance.GetChildParent;
  3738.   try
  3739.     Owner := Instance.GetChildOwner;
  3740.     if not Assigned(Owner) then Owner := Root;
  3741.     while not EndOfList do ReadComponent(nil);
  3742.     ReadListEnd;
  3743.   finally
  3744.     Parent := OldParent;
  3745.     Owner := OldOwner;
  3746.   end;
  3747. end;
  3748.  
  3749. function TReader.ReadFloat: Extended;
  3750. begin
  3751.   if ReadValue = vaExtended then Read(Result, SizeOf(Result)) else
  3752.   begin
  3753.     Dec(FBufPos);
  3754.     Result := ReadInteger;
  3755.   end;
  3756. end;
  3757.  
  3758. function TReader.ReadIdent: string;
  3759. var
  3760.   L: Byte;
  3761. begin
  3762.   case ReadValue of
  3763.     vaIdent:
  3764.       begin
  3765.         Read(L, SizeOf(Byte));
  3766.         SetString(Result, PChar(nil), L);
  3767.         Read(Result[1], L);
  3768.       end;
  3769.     vaFalse:
  3770.       Result := 'False';
  3771.     vaTrue:
  3772.       Result := 'True';
  3773.     vaNil:
  3774.       Result := 'nil';
  3775.   else
  3776.     PropValueError;
  3777.   end;
  3778. end;
  3779.  
  3780. function TReader.ReadInteger: Longint;
  3781. var
  3782.   S: Shortint;
  3783.   I: Smallint;
  3784. begin
  3785.   case ReadValue of
  3786.     vaInt8:
  3787.       begin
  3788.         Read(S, SizeOf(Shortint));
  3789.         Result := S;
  3790.       end;
  3791.     vaInt16:
  3792.       begin
  3793.         Read(I, SizeOf(I));
  3794.         Result := I;
  3795.       end;
  3796.     vaInt32:
  3797.       Read(Result, SizeOf(Result));
  3798.   else
  3799.     PropValueError;
  3800.   end;
  3801. end;
  3802.  
  3803. procedure TReader.ReadListBegin;
  3804. begin
  3805.   CheckValue(vaList);
  3806. end;
  3807.  
  3808. procedure TReader.ReadListEnd;
  3809. begin
  3810.   CheckValue(vaNull);
  3811. end;
  3812.  
  3813. procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  3814. var
  3815.   Prefix: Byte;
  3816. begin
  3817.   Flags := [];
  3818.   if Byte(NextValue) and $F0 = $F0 then
  3819.   begin
  3820.     Prefix := Byte(ReadValue);
  3821.     Byte(Flags) := Prefix and $0F;
  3822.     if ffChildPos in Flags then AChildPos := ReadInteger;
  3823.   end;
  3824. end;
  3825.  
  3826. procedure TReader.ReadProperty(AInstance: TPersistent);
  3827. var
  3828.   I, J, L: Integer;
  3829.   Instance: TPersistent;
  3830.   PropInfo: PPropInfo;
  3831.   PropValue: TObject;
  3832.   PropPath: string;
  3833.  
  3834.   procedure HandleException(E: Exception);
  3835.   var
  3836.     Name: string;
  3837.   begin
  3838.     Name := '';
  3839.     if AInstance is TComponent then
  3840.       Name := TComponent(AInstance).Name;
  3841.     if Name = '' then Name := AInstance.ClassName;
  3842.     raise EReadError.CreateFmt(SPropertyException, [Name, PropPath, E.Message]);
  3843.   end;
  3844.  
  3845.   procedure PropPathError;
  3846.   begin
  3847.     SkipValue;
  3848.     ReadError(SInvalidPropertyPath);
  3849.   end;
  3850.  
  3851. begin
  3852.   try
  3853.     PropPath := ReadStr;
  3854.     try
  3855.       I := 1;
  3856.       L := Length(PropPath);
  3857.       Instance := AInstance;
  3858.       FCanHandleExcepts := True;
  3859.       while True do
  3860.       begin
  3861.         J := I;
  3862.         while (I <= L) and (PropPath[I] <> '.') do Inc(I);
  3863.         FPropName := Copy(PropPath, J, I - J);
  3864.         if I > L then Break;
  3865.         PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  3866.         if PropInfo = nil then PropertyError;
  3867.         PropValue := nil;
  3868.         if PropInfo^.PropType^.Kind = tkClass then
  3869.           PropValue := TObject(GetOrdProp(Instance, PropInfo));
  3870.         if not (PropValue is TPersistent) then PropPathError;
  3871.         Instance := TPersistent(PropValue);
  3872.         Inc(I);
  3873.       end;
  3874.       PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  3875.       if PropInfo <> nil then ReadPropValue(Instance, PropInfo) else
  3876.       begin
  3877.         { Cannot reliably recover from an error in a defined property }
  3878.         FCanHandleExcepts := False;
  3879.         Instance.DefineProperties(Self);
  3880.         FCanHandleExcepts := True;
  3881.         if FPropName <> '' then PropertyError;
  3882.       end;
  3883.     except
  3884.       on E: Exception do HandleException(E);
  3885.     end;
  3886.   except
  3887.     on E: Exception do
  3888.       if not FCanHandleExcepts or not Error(E.Message) then raise;
  3889.   end;
  3890. end;
  3891.  
  3892. procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  3893. const
  3894.   NilMethod: TMethod = (Code: nil; Data: nil);
  3895. var
  3896.   PropType: PTypeInfo;
  3897.   Method: TMethod;
  3898.  
  3899.   procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
  3900.     const Ident: string);
  3901.   var
  3902.     I: Integer;
  3903.     V: Longint;
  3904.   begin
  3905.     for I := 0 to IntConstList.Count - 1 do
  3906.       with TIntConst(IntConstList[I]) do
  3907.         if PPropInfo(PropInfo)^.PropType^ = IntegerType then
  3908.           if IdentToInt(Ident, V) then
  3909.           begin
  3910.             SetOrdProp(Instance, PropInfo, V);
  3911.             Exit;
  3912.           end;
  3913.     PropValueError;
  3914.   end;
  3915.  
  3916.   procedure SetObjectIdent(Instance: TPersistent; PropInfo: Pointer;
  3917.     const Ident: string);
  3918.   var
  3919.     RootName, Name: string;
  3920.     P: Integer;
  3921.     Fixup: TPropFixup;
  3922.   begin
  3923.     RootName := '';
  3924.     Name := Ident;
  3925.     P := Pos('.', Ident);
  3926.     if P <> 0 then
  3927.     begin
  3928.       RootName := Copy(Ident, 1, P - 1);
  3929.       Name := Copy(Ident, P + 1, MaxInt);
  3930.     end;
  3931.     Fixup := TPropFixup.Create(Instance, Root, PropInfo, RootName, Name);
  3932.     if RootName = '' then
  3933.       FFixups.Add(Fixup) else
  3934.       GlobalFixupList.Add(Fixup);
  3935.   end;
  3936.  
  3937. begin
  3938.   if PPropInfo(PropInfo)^.SetProc = nil then ReadError(SReadOnlyProperty);
  3939.   PropType := PPropInfo(PropInfo)^.PropType^;
  3940.   case PropType^.Kind of
  3941.     tkInteger:
  3942.       if NextValue = vaIdent then
  3943.         SetIntIdent(Instance, PropInfo, ReadIdent) else
  3944.         SetOrdProp(Instance, PropInfo, ReadInteger);
  3945.     tkChar:
  3946.       SetOrdProp(Instance, PropInfo, Ord(ReadChar));
  3947.     tkEnumeration:
  3948.       SetOrdProp(Instance, PropInfo, EnumValue(PropType, ReadIdent));
  3949.     tkFloat:
  3950.       SetFloatProp(Instance, PropInfo, ReadFloat);
  3951.     tkString, tkLString, tkWString:
  3952.       SetStrProp(Instance, PropInfo, ReadString);
  3953.     tkSet:
  3954.       SetOrdProp(Instance, PropInfo, ReadSet(PropType));
  3955.     tkClass:
  3956.       case NextValue of
  3957.         vaNil:
  3958.           begin
  3959.             ReadValue;
  3960.             SetOrdProp(Instance, PropInfo, 0)
  3961.           end;
  3962.         vaCollection:
  3963.           begin
  3964.             ReadValue;
  3965.             ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
  3966.           end
  3967.       else
  3968.         SetObjectIdent(Instance, PropInfo, ReadIdent);
  3969.       end;
  3970.     tkMethod:
  3971.       if NextValue = vaNil then
  3972.       begin
  3973.         ReadValue;
  3974.         SetMethodProp(Instance, PropInfo, NilMethod);
  3975.       end
  3976.       else
  3977.       begin
  3978.         Method.Code :=  FindMethod(Root, ReadIdent);
  3979.         Method.Data := Root;
  3980.         if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
  3981.       end;
  3982.   end;
  3983. end;
  3984.  
  3985. function TReader.ReadRootComponent(Root: TComponent): TComponent;
  3986.  
  3987.   function FindUniqueName(const Name: string): string;
  3988.   var
  3989.     I: Integer;
  3990.   begin
  3991.     I := 0;
  3992.     Result := '';
  3993.     if Assigned(FindGlobalComponent) then
  3994.     begin
  3995.       Result := Name;
  3996.       while FindGlobalComponent(Result) <> nil do
  3997.       begin
  3998.         Inc(I);
  3999.         Result := Format('%s_%d', [Name, I]);
  4000.       end;
  4001.     end;
  4002.   end;
  4003.  
  4004. var
  4005.   I: Integer;
  4006.   Flags: TFilerFlags;
  4007. begin
  4008.   ReadSignature;
  4009.   Result := nil;
  4010.   try
  4011.     ReadPrefix(Flags, I);
  4012.     if Root = nil then
  4013.     begin
  4014.       Result := TComponentClass(FindClass(ReadStr)).Create(nil);
  4015.       Result.Name := ReadStr;
  4016.     end else
  4017.     begin
  4018.       Result := Root;
  4019.       ReadStr; { Ignore class name }
  4020.       if csDesigning in Result.ComponentState then
  4021.         ReadStr else
  4022.         Result.Name := FindUniqueName(ReadStr);
  4023.     end;
  4024.     FRoot := Result;
  4025.     if GlobalLoaded <> nil then
  4026.       FLoaded := GlobalLoaded else
  4027.       FLoaded := TList.Create;
  4028.     try
  4029.       FLoaded.Add(FRoot);
  4030.       FOwner := FRoot;
  4031.       Include(FRoot.FComponentState, csLoading);
  4032.       Include(FRoot.FComponentState, csReading);
  4033.       FRoot.ReadState(Self);
  4034.       Exclude(FRoot.FComponentState, csReading);
  4035.       if GlobalLoaded = nil then
  4036.         for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  4037.     finally
  4038.       if GlobalLoaded = nil then FLoaded.Free;
  4039.       FLoaded := nil;
  4040.     end;
  4041.     GlobalFixupReferences;
  4042.   except
  4043.     RemoveFixupReferences(Root, '');
  4044.     if Root = nil then Result.Free;
  4045.     raise;
  4046.   end;
  4047. end;
  4048.  
  4049. procedure TReader.ReadComponents(AOwner, AParent: TComponent;
  4050.   Proc: TReadComponentsProc);
  4051. var
  4052.   Component: TComponent;
  4053. begin
  4054.   Root := AOwner;
  4055.   Owner := AOwner;
  4056.   Parent := AParent;
  4057.   BeginReferences;
  4058.   try
  4059.     while not EndOfList do
  4060.     begin
  4061.       ReadSignature;
  4062.       Component := ReadComponent(nil);
  4063.       Proc(Component);
  4064.     end;
  4065.     ReadListEnd;
  4066.     FixupReferences;
  4067.   finally
  4068.     EndReferences;
  4069.   end;
  4070. end;
  4071.  
  4072. function TReader.ReadSet(SetType: Pointer): Integer;
  4073. var
  4074.   EnumType: PTypeInfo;
  4075.   EnumName: string;
  4076. begin
  4077.   try
  4078.     if ReadValue <> vaSet then PropValueError;
  4079.     EnumType := GetTypeData(SetType)^.CompType^;
  4080.     Result := 0;
  4081.     while True do
  4082.     begin
  4083.       EnumName := ReadStr;
  4084.       if EnumName = '' then Break;
  4085.       Include(TIntegerSet(Result), EnumValue(EnumType, EnumName));
  4086.     end;
  4087.   except
  4088.     SkipSetBody;
  4089.     raise;
  4090.   end;
  4091. end;
  4092.  
  4093. procedure TReader.ReadSignature;
  4094. var
  4095.   Signature: Longint;
  4096. begin
  4097.   Read(Signature, SizeOf(Signature));
  4098.   if Signature <> Longint(FilerSignature) then ReadError(SInvalidImage);
  4099. end;
  4100.  
  4101. function TReader.ReadStr: string;
  4102. var
  4103.   L: Byte;
  4104. begin
  4105.   Read(L, SizeOf(Byte));
  4106.   SetString(Result, PChar(nil), L);
  4107.   Read(Result[1], L);
  4108. end;
  4109.  
  4110. function TReader.ReadString: string;
  4111. var
  4112.   L: Integer;
  4113. begin
  4114.   L := 0;
  4115.   case ReadValue of
  4116.     vaString:
  4117.       Read(L, SizeOf(Byte));
  4118.     vaLString:
  4119.       Read(L, SizeOf(Integer));
  4120.   else
  4121.     PropValueError;
  4122.   end;
  4123.   SetString(Result, PChar(nil), L);
  4124.   Read(Pointer(Result)^, L);
  4125. end;
  4126.  
  4127. function TReader.ReadValue: TValueType;
  4128. begin
  4129.   Read(Result, SizeOf(Result));
  4130. end;
  4131.  
  4132. procedure TReader.SetPosition(Value: Longint);
  4133. begin
  4134.   FStream.Position := Value;
  4135.   FBufPos := 0;
  4136.   FBufEnd := 0;
  4137. end;
  4138.  
  4139. procedure TReader.SkipSetBody;
  4140. begin
  4141.   while ReadStr <> '' do begin end;
  4142. end;
  4143.  
  4144. procedure TReader.SkipValue;
  4145.  
  4146.   procedure SkipList;
  4147.   begin
  4148.     while not EndOfList do SkipValue;
  4149.     ReadListEnd;
  4150.   end;
  4151.  
  4152.   procedure SkipBytes(Count: Longint);
  4153.   var
  4154.     Bytes: array[0..255] of Char;
  4155.   begin
  4156.     while Count > 0 do
  4157.       if Count > SizeOf(Bytes) then
  4158.       begin
  4159.         Read(Bytes, SizeOf(Bytes));
  4160.         Dec(Count, SizeOf(Bytes));
  4161.       end
  4162.       else
  4163.       begin
  4164.         Read(Bytes, Count);
  4165.         Count := 0;
  4166.       end;
  4167.   end;
  4168.  
  4169.   procedure SkipBinary;
  4170.   var
  4171.     Count: Longint;
  4172.   begin
  4173.     Read(Count, SizeOf(Count));
  4174.     SkipBytes(Count);
  4175.   end;
  4176.  
  4177.   procedure SkipCollection;
  4178.   begin
  4179.     while not EndOfList do
  4180.     begin
  4181.       if NextValue in [vaInt8, vaInt16, vaInt32] then SkipValue;
  4182.       SkipBytes(1);
  4183.       while not EndOfList do SkipProperty;
  4184.       ReadListEnd;
  4185.     end;
  4186.     ReadListEnd;
  4187.   end;
  4188.  
  4189. begin
  4190.   case ReadValue of
  4191.     vaNull: begin end;
  4192.     vaList: SkipList;
  4193.     vaInt8: SkipBytes(1);
  4194.     vaInt16: SkipBytes(2);
  4195.     vaInt32: SkipBytes(4);
  4196.     vaExtended: SkipBytes(SizeOf(Extended));
  4197.     vaString, vaIdent: ReadStr;
  4198.     vaFalse, vaTrue: begin end;
  4199.     vaBinary: SkipBinary;
  4200.     vaSet: SkipSetBody;
  4201.     vaCollection: SkipCollection;
  4202.   end;
  4203. end;
  4204.  
  4205. procedure TReader.CopyValue(Writer: TWriter);
  4206.  
  4207.   procedure CopySetBody;
  4208.   var
  4209.     s: String;
  4210.   begin
  4211.     Writer.WriteValue(ReadValue);
  4212.     repeat
  4213.       s := ReadStr;
  4214.       Writer.WriteStr(s);
  4215.     until s = '';
  4216.   end;
  4217.  
  4218.   procedure CopyList;
  4219.   begin
  4220.     Writer.WriteValue(ReadValue);
  4221.     while not EndOfList do
  4222.       CopyValue(Writer);
  4223.     ReadListEnd;
  4224.     Writer.WriteListEnd;
  4225.   end;
  4226.  
  4227.   procedure CopyBytes(Count: Longint);
  4228.   var
  4229.     Bytes: array[0..8191] of Char;
  4230.   begin
  4231.     while Count > sizeof(Bytes) do
  4232.     begin
  4233.       Read(Bytes, sizeof(Bytes));
  4234.       Writer.Write(Bytes, sizeof(Bytes));
  4235.       Dec(Count, sizeof(Bytes));
  4236.     end;
  4237.     if Count > 0 then
  4238.     begin
  4239.       Read(Bytes, Count);
  4240.       Writer.Write(Bytes, Count);
  4241.     end;
  4242.   end;
  4243.  
  4244.   procedure CopyBinary;
  4245.   var
  4246.     Count: Longint;
  4247.   begin
  4248.     Writer.WriteValue(ReadValue);
  4249.     Read(Count, SizeOf(Count));
  4250.     Writer.Write(Count, SizeOf(Count));
  4251.     CopyBytes(Count);
  4252.   end;
  4253.  
  4254. begin
  4255.   case NextValue of
  4256.     vaNull, vaFalse, vaTrue, vaNil: Writer.WriteValue(ReadValue);
  4257.     vaList, vaCollection: CopyList;
  4258.     vaInt8, vaInt16, vaInt32: Writer.WriteInteger(ReadInteger);
  4259.     vaExtended: Writer.WriteFloat(ReadFloat);
  4260.     vaString, vaLString: Writer.WriteStr(ReadStr);
  4261.     vaIdent: Writer.WriteIdent(ReadIdent);
  4262.     vaBinary: CopyBinary;
  4263.     vaSet: CopySetBody;
  4264.   end;
  4265. end;
  4266.  
  4267. procedure TReader.SkipProperty;
  4268. begin
  4269.   ReadStr; { Skips property name }
  4270.   SkipValue;
  4271. end;
  4272.  
  4273. procedure TReader.SkipComponent(SkipHeader: Boolean);
  4274. var
  4275.   Flags: TFilerFlags;
  4276.   Position: Integer;
  4277. begin
  4278.   if SkipHeader then
  4279.   begin
  4280.     ReadPrefix(Flags, Position);
  4281.     ReadStr;
  4282.     ReadStr;
  4283.   end;
  4284.   while not EndOfList do SkipProperty;
  4285.   ReadListEnd;
  4286.   while not EndOfList do SkipComponent(True);
  4287.   ReadListEnd;
  4288. end;
  4289.  
  4290. procedure TReader.ReferenceName(var Name: string);
  4291. begin
  4292.   if Assigned(FOnReferenceName) then FOnReferenceName(Self, Name);
  4293. end;
  4294.  
  4295. procedure TReader.SetName(Component: TComponent; var Name: string);
  4296. begin
  4297.   if Assigned(FOnSetName) then FOnSetName(Self, Component, Name);
  4298.   Component.Name := Name;
  4299. end;
  4300.  
  4301. { TWriter }
  4302.  
  4303. destructor TWriter.Destroy;
  4304. begin
  4305.   WriteBuffer;
  4306.   inherited Destroy;
  4307. end;
  4308.  
  4309. procedure TWriter.AddAncestor(Component: TComponent);
  4310. begin
  4311.   FAncestorList.Add(Component);
  4312. end;
  4313.  
  4314. procedure TWriter.DefineProperty(const Name: string;
  4315.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  4316. begin
  4317.   if HasData and Assigned(WriteData) then
  4318.   begin
  4319.     WritePropName(Name);
  4320.     WriteData(Self);
  4321.   end;
  4322. end;
  4323.  
  4324. procedure TWriter.DefineBinaryProperty(const Name: string;
  4325.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  4326. begin
  4327.   if HasData and Assigned(WriteData) then
  4328.   begin
  4329.     WritePropName(Name);
  4330.     WriteBinary(WriteData);
  4331.   end;
  4332. end;
  4333.  
  4334. function TWriter.GetPosition: Longint;
  4335. begin
  4336.   Result := FStream.Position + FBufPos;
  4337. end;
  4338.  
  4339. procedure TWriter.FlushBuffer;
  4340. begin
  4341.   WriteBuffer;
  4342. end;
  4343.  
  4344. procedure TWriter.SetPosition(Value: Longint);
  4345. var
  4346.   StreamPosition: Longint;
  4347. begin
  4348.   StreamPosition := FStream.Position;
  4349.   { Only flush the buffer if the repostion is outside the buffer range }
  4350.   if (Value < StreamPosition) or (Value > StreamPosition + FBufPos) then
  4351.   begin
  4352.     WriteBuffer;
  4353.     FStream.Position := Value;
  4354.   end
  4355.   else FBufPos := Value - StreamPosition;
  4356. end;
  4357.  
  4358. procedure TWriter.Write(const Buf; Count: Longint); assembler;
  4359. asm
  4360.         PUSH    ESI
  4361.         PUSH    EDI
  4362.         PUSH    EBX
  4363.         MOV     ESI,EDX
  4364.         MOV     EBX,ECX
  4365.         MOV     EDI,EAX
  4366.         JMP     @@6
  4367. @@1:    MOV     ECX,[EDI].TWriter.FBufSize
  4368.         SUB     ECX,[EDI].TWriter.FBufPos
  4369.         JA      @@2
  4370.         MOV     EAX,EDI
  4371.         CALL    TWriter.WriteBuffer
  4372.         MOV     ECX,[EDI].TWriter.FBufSize
  4373. @@2:    CMP     ECX,EBX
  4374.         JB      @@3
  4375.         MOV     ECX,EBX
  4376. @@3:    SUB     EBX,ECX
  4377.         PUSH    EDI
  4378.         MOV     EAX,[EDI].TWriter.FBuffer
  4379.         ADD     EAX,[EDI].TWriter.FBufPos
  4380.         ADD     [EDI].TWriter.FBufPos,ECX
  4381. @@5:    MOV     EDI,EAX
  4382.         MOV     EDX,ECX
  4383.         SHR     ECX,2
  4384.         CLD
  4385.         REP     MOVSD
  4386.         MOV     ECX,EDX
  4387.         AND     ECX,3
  4388.         REP     MOVSB
  4389.         POP     EDI
  4390. @@6:    OR      EBX,EBX
  4391.         JNE     @@1
  4392.         POP     EBX
  4393.         POP     EDI
  4394.         POP     ESI
  4395. end;
  4396.  
  4397. procedure TWriter.WriteBinary(WriteData: TStreamProc);
  4398. var
  4399.   Stream: TMemoryStream;
  4400.   Count: Longint;
  4401. begin
  4402.   Stream := TMemoryStream.Create;
  4403.   try
  4404.     WriteData(Stream);
  4405.     WriteValue(vaBinary);
  4406.     Count := Stream.Size;
  4407.     Write(Count, SizeOf(Count));
  4408.     Write(Stream.Memory^, Count);
  4409.   finally
  4410.     Stream.Free;
  4411.   end;
  4412. end;
  4413.  
  4414. procedure TWriter.WriteBuffer;
  4415. begin
  4416.   FStream.WriteBuffer(FBuffer^, FBufPos);
  4417.   FBufPos := 0;
  4418. end;
  4419.  
  4420. procedure TWriter.WriteBoolean(Value: Boolean);
  4421. begin
  4422.   if Value then
  4423.     WriteValue(vaTrue) else
  4424.     WriteValue(vaFalse);
  4425. end;
  4426.  
  4427. procedure TWriter.WriteChar(Value: Char);
  4428. begin
  4429.   WriteString(Value);
  4430. end;
  4431.  
  4432. procedure TWriter.WriteCollection(Value: TCollection);
  4433. var
  4434.   I: Integer;
  4435. begin
  4436.   WriteValue(vaCollection);
  4437.   for I := 0 to Value.Count - 1 do
  4438.   begin
  4439.     WriteListBegin;
  4440.     WriteProperties(Value.Items[I]);
  4441.     WriteListEnd;
  4442.   end;
  4443.   WriteListEnd;
  4444. end;
  4445.  
  4446. procedure TWriter.WriteComponent(Component: TComponent);
  4447.  
  4448.   function FindAncestor(const Name: string): TComponent;
  4449.   var
  4450.     I: Integer;
  4451.   begin
  4452.     for I := 0 to FAncestorList.Count - 1 do
  4453.     begin
  4454.       Result := FAncestorList[I];
  4455.       if CompareText(Result.Name, Name) = 0 then Exit;
  4456.     end;
  4457.     Result := nil;
  4458.   end;
  4459.  
  4460. begin
  4461.   Include(Component.FComponentState, csWriting);
  4462.   if Assigned(FAncestorList) then
  4463.     Ancestor := FindAncestor(Component.Name);
  4464.   Component.WriteState(Self);
  4465.   Exclude(Component.FComponentState, csWriting);
  4466. end;
  4467.  
  4468. procedure TWriter.WriteData(Instance: TComponent);
  4469. var
  4470.   PreviousPosition, PropertiesPosition: Longint;
  4471.   OldAncestorList: TList;
  4472.   OldAncestorPos, OldChildPos: Integer;
  4473.   Flags: TFilerFlags;
  4474. begin
  4475.   if FBufSize - FBufPos < Length(Instance.ClassName) +
  4476.     Length(Instance.Name) + 1+5+3 then WriteBuffer;
  4477.      { Prefix + vaInt + integer + 2 end lists }
  4478.   PreviousPosition := Position;
  4479.   Flags := [];
  4480.   if Ancestor <> nil then Include(Flags, ffInherited);
  4481.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) and
  4482.     ((Ancestor = nil) or (FAncestorList[FAncestorPos] <> Ancestor)) then
  4483.     Include(Flags, ffChildPos);
  4484.   WritePrefix(Flags, FChildPos);
  4485.   WriteStr(Instance.ClassName);
  4486.   WriteStr(Instance.Name);
  4487.   PropertiesPosition := Position;
  4488.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) then
  4489.   begin
  4490.     if Ancestor <> nil then Inc(FAncestorPos);
  4491.     Inc(FChildPos);
  4492.   end;
  4493.   WriteProperties(Instance);
  4494.   WriteListEnd;
  4495.   OldAncestorList := FAncestorList;
  4496.   OldAncestorPos := FAncestorPos;
  4497.   OldChildPos := FChildPos;
  4498.   try
  4499.     FAncestorList := nil;
  4500.     FAncestorPos := 0;
  4501.     FChildPos := 0;
  4502.     if not IgnoreChildren then
  4503.       try
  4504.         if (FAncestor <> nil) and (FAncestor is TComponent) then
  4505.         begin
  4506.           FAncestorList := TList.Create;
  4507.           TComponent(FAncestor).GetChildren(AddAncestor, FRootAncestor);
  4508.         end;
  4509.         Instance.GetChildren(WriteComponent, FRoot);
  4510.       finally
  4511.         FAncestorList.Free;
  4512.       end;
  4513.   finally
  4514.     FAncestorList := OldAncestorList;
  4515.     FAncestorPos := OldAncestorPos;
  4516.     FChildPos := OldChildPos;
  4517.   end;
  4518.   WriteListEnd;
  4519.   if (Instance <> Root) and (Flags = [ffInherited]) and
  4520.     (Position = PropertiesPosition + (1 + 1)) then { (1 + 1) is two end lists }
  4521.     Position := PreviousPosition;
  4522. end;
  4523.  
  4524. procedure TWriter.WriteDescendent(Root: TComponent; AAncestor: TComponent);
  4525. begin
  4526.   FRootAncestor := AAncestor;
  4527.   FAncestor := AAncestor;
  4528.   FRoot := Root;
  4529.   WriteSignature;
  4530.   WriteComponent(Root);
  4531. end;
  4532.  
  4533. procedure TWriter.WriteFloat(Value: Extended);
  4534. begin
  4535.   WriteValue(vaExtended);
  4536.   Write(Value, SizeOf(Extended));
  4537. end;
  4538.  
  4539. procedure TWriter.WriteIdent(const Ident: string);
  4540. begin
  4541.   if CompareText(Ident, 'False') = 0 then WriteValue(vaFalse) else
  4542.   if CompareText(Ident ,'True') = 0 then WriteValue(vaTrue) else
  4543.   if CompareText(Ident, 'nil') = 0 then WriteValue(vaNil) else
  4544.   begin
  4545.     WriteValue(vaIdent);
  4546.     WriteStr(Ident);
  4547.   end;
  4548. end;
  4549.  
  4550. procedure TWriter.WriteInteger(Value: Longint);
  4551. begin
  4552.   if (Value >= -128) and (Value <= 127) then
  4553.   begin
  4554.     WriteValue(vaInt8);
  4555.     Write(Value, SizeOf(Shortint));
  4556.   end else
  4557.   if (Value >= -32768) and (Value <= 32767) then
  4558.   begin
  4559.     WriteValue(vaInt16);
  4560.     Write(Value, SizeOf(Smallint));
  4561.   end else
  4562.   begin
  4563.     WriteValue(vaInt32);
  4564.     Write(Value, SizeOf(Longint));
  4565.   end;
  4566. end;
  4567.  
  4568. procedure TWriter.WriteListBegin;
  4569. begin
  4570.   WriteValue(vaList);
  4571. end;
  4572.  
  4573. procedure TWriter.WriteListEnd;
  4574. begin
  4575.   WriteValue(vaNull);
  4576. end;
  4577.  
  4578. procedure TWriter.WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  4579. var
  4580.   Prefix: Byte;
  4581. begin
  4582.   if Flags <> [] then
  4583.   begin
  4584.     Prefix := $F0 or Byte(Flags);
  4585.     Write(Prefix, SizeOf(Prefix));
  4586.     if ffChildPos in Flags then WriteInteger(AChildPos);
  4587.   end;
  4588. end;
  4589.  
  4590. procedure TWriter.WriteProperties(Instance: TPersistent);
  4591. var
  4592.   I, Count: Integer;
  4593.   PropInfo: PPropInfo;
  4594.   PropList: PPropList;
  4595. begin
  4596.   Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  4597.   if Count > 0 then
  4598.   begin
  4599.     GetMem(PropList, Count * SizeOf(Pointer));
  4600.     try
  4601.       GetPropInfos(Instance.ClassInfo, PropList);
  4602.       for I := 0 to Count - 1 do
  4603.       begin
  4604.         PropInfo := PropList^[I];
  4605.         if IsStoredProp(Instance, PropInfo) then
  4606.           WriteProperty(Instance, PropInfo);
  4607.       end;
  4608.     finally
  4609.       FreeMem(PropList, Count * SizeOf(Pointer));
  4610.     end;
  4611.   end;
  4612.   Instance.DefineProperties(Self);
  4613. end;
  4614.  
  4615. procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  4616. var
  4617.   PropType: PTypeInfo;
  4618.  
  4619.   function AncestorValid: Boolean;
  4620.   begin
  4621.     Result := (Ancestor <> nil) and ((Instance.ClassType = Ancestor.ClassType) or
  4622.       (Instance = Root));
  4623.   end;
  4624.  
  4625.   procedure WritePropPath;
  4626.   begin
  4627.     WritePropName(PPropInfo(PropInfo)^.Name);
  4628.   end;
  4629.  
  4630.   procedure WriteSet(Value: Longint);
  4631.   var
  4632.     I: Integer;
  4633.     BaseType: PTypeInfo;
  4634.   begin
  4635.     BaseType := GetTypeData(PropType)^.CompType^;
  4636.     WriteValue(vaSet);
  4637.     for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
  4638.       if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
  4639.     WriteStr('');
  4640.   end;
  4641.  
  4642.   procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  4643.   var
  4644.     I: Integer;
  4645.     Ident: string;
  4646.   begin
  4647.     for I := 0 to IntConstList.Count - 1 do
  4648.       with TIntConst(IntConstList[I]) do
  4649.         if IntType = IntegerType then
  4650.           if IntToIdent(Value, Ident) then
  4651.           begin
  4652.             WriteIdent(Ident);
  4653.             Exit;
  4654.           end
  4655.           else Break;
  4656.     WriteInteger(Value);
  4657.   end;
  4658.  
  4659.   procedure WriteCollectionProp(Collection: TCollection);
  4660.   var
  4661.     SavePropPath: string;
  4662.   begin
  4663.     WritePropPath;
  4664.     SavePropPath := FPropPath;
  4665.     try
  4666.       FPropPath := '';
  4667.       WriteCollection(Collection);
  4668.     finally
  4669.       FPropPath := SavePropPath;
  4670.     end;
  4671.   end;
  4672.  
  4673.   procedure WriteOrdProp;
  4674.   var
  4675.     Value: Longint;
  4676.  
  4677.     function IsDefaultValue: Boolean;
  4678.     begin
  4679.       if AncestorValid then
  4680.         Result := Value = GetOrdProp(Ancestor, PropInfo) else
  4681.         Result := Value = PPropInfo(PropInfo)^.Default;
  4682.     end;
  4683.  
  4684.   begin
  4685.     Value := GetOrdProp(Instance, PropInfo);
  4686.     if not IsDefaultValue then
  4687.     begin
  4688.       WritePropPath;
  4689.       case PropType^.Kind of
  4690.         tkInteger:
  4691.           WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value);
  4692.         tkChar:
  4693.           WriteChar(Chr(Value));
  4694.         tkSet:
  4695.           WriteSet(Value);
  4696.         tkEnumeration:
  4697.           WriteIdent(GetEnumName(PropType, Value));
  4698.       end;
  4699.     end;
  4700.   end;
  4701.  
  4702.   procedure WriteFloatProp;
  4703.   var
  4704.     Value: Extended;
  4705.  
  4706.     function IsDefaultValue: Boolean;
  4707.     begin
  4708.       if AncestorValid then
  4709.         Result := Value = GetFloatProp(Ancestor, PropInfo) else
  4710.         Result := Value = 0;
  4711.     end;
  4712.  
  4713.   begin
  4714.     Value := GetFloatProp(Instance, PropInfo);
  4715.     if not IsDefaultValue then
  4716.     begin
  4717.       WritePropPath;
  4718.       WriteFloat(Value);
  4719.     end;
  4720.   end;
  4721.  
  4722.   procedure WriteStrProp;
  4723.   var
  4724.     Value: string;
  4725.  
  4726.     function IsDefault: Boolean;
  4727.     begin
  4728.       if AncestorValid then
  4729.         Result := Value = GetStrProp(Ancestor, PropInfo) else
  4730.         Result := Value = '';
  4731.     end;
  4732.  
  4733.   begin
  4734.     Value := GetStrProp(Instance, PropInfo);
  4735.     if not IsDefault then
  4736.     begin
  4737.       WritePropPath;
  4738.       WriteString(Value);
  4739.     end;
  4740.   end;
  4741.  
  4742.   procedure WriteObjectProp;
  4743.   var
  4744.     Value: TObject;
  4745.     OldAncestor: TPersistent;
  4746.     SavePropPath, ComponentValue: string;
  4747.  
  4748.     function IsDefault: Boolean;
  4749.     var
  4750.       AncestorValue: TObject;
  4751.     begin
  4752.       AncestorValue := nil;
  4753.       if AncestorValid then
  4754.       begin
  4755.         AncestorValue := TObject(GetOrdProp(Ancestor, PropInfo));
  4756.         if (AncestorValue <> nil) and (TComponent(AncestorValue).Owner = FRootAncestor) and
  4757.           (Value <> nil) and (TComponent(Value).Owner = Root) and
  4758.           (CompareText(TComponent(AncestorValue).Name, TComponent(Value).Name) = 0) then
  4759.           AncestorValue := Value;
  4760.       end;
  4761.       Result := Value = AncestorValue;
  4762.     end;
  4763.  
  4764.     function GetComponentValue(Component: TComponent): string;
  4765.     begin
  4766.       if Component.Owner = Root then
  4767.         Result := Component.Name
  4768.       else if Component.Owner <> nil then
  4769.         Result := Component.Owner.Name + '.' + Component.Name
  4770.       else Result := '';
  4771.     end;
  4772.  
  4773.   begin
  4774.     Value := TObject(GetOrdProp(Instance, PropInfo));
  4775.     if (Value = nil) and not IsDefault then
  4776.     begin
  4777.       WritePropPath;
  4778.       WriteValue(vaNil);
  4779.     end
  4780.     else if Value is TPersistent then
  4781.       if Value is TComponent then
  4782.       begin
  4783.         if not IsDefault then
  4784.         begin
  4785.           ComponentValue := GetComponentValue(TComponent(Value));
  4786.           if ComponentValue <> '' then
  4787.           begin
  4788.             WritePropPath;
  4789.             WriteIdent(ComponentValue);
  4790.           end
  4791.         end
  4792.       end else if Value is TCollection then
  4793.       begin
  4794.         if not AncestorValid or
  4795.           not CollectionsEqual(TCollection(Value),
  4796.             TCollection(GetOrdProp(Ancestor, PropInfo))) then
  4797.             WriteCollectionProp(TCollection(Value));
  4798.       end else
  4799.       begin
  4800.         OldAncestor := Ancestor;
  4801.         SavePropPath := FPropPath;
  4802.         FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
  4803.         if AncestorValid then
  4804.           Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo));
  4805.         WriteProperties(TPersistent(Value));
  4806.         Ancestor := OldAncestor;
  4807.         FPropPath := SavePropPath;
  4808.       end
  4809.   end;
  4810.  
  4811.   procedure WriteMethodProp;
  4812.   var
  4813.     Value: TMethod;
  4814.  
  4815.     function IsDefaultValue: Boolean;
  4816.     var
  4817.       DefaultCode: Pointer;
  4818.     begin
  4819.       DefaultCode := nil;
  4820.       if AncestorValid then DefaultCode := GetMethodProp(Ancestor, PropInfo).Code;
  4821.       Result := (Value.Code = DefaultCode) or
  4822.         ((Value.Code <> nil) and (Root.MethodName(Value.Code) = ''));
  4823.     end;
  4824.  
  4825.   begin
  4826.     Value := GetMethodProp(Instance, PropInfo);
  4827.     if not IsDefaultValue then
  4828.     begin
  4829.       WritePropPath;
  4830.       if Value.Code = nil then
  4831.         WriteValue(vaNil) else
  4832.         WriteIdent(Root.MethodName(Value.Code));
  4833.     end;
  4834.   end;
  4835.  
  4836. begin
  4837.   if PPropInfo(PropInfo)^.SetProc <> nil then
  4838.   begin
  4839.     PropType := PPropInfo(PropInfo)^.PropType^;
  4840.     case PropType^.Kind of
  4841.       tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
  4842.       tkFloat: WriteFloatProp;
  4843.       tkString, tkLString, tkWString: WriteStrProp;
  4844.       tkClass: WriteObjectProp;
  4845.       tkMethod: WriteMethodProp;
  4846.     end;
  4847.   end;
  4848. end;
  4849.  
  4850. procedure TWriter.WritePropName(const PropName: string);
  4851. begin
  4852.   WriteStr(FPropPath + PropName);
  4853. end;
  4854.  
  4855. procedure TWriter.WriteRootComponent(Root: TComponent);
  4856. begin
  4857.   WriteDescendent(Root, nil);
  4858. end;
  4859.  
  4860. procedure TWriter.WriteSignature;
  4861. begin
  4862.   Write(FilerSignature, SizeOf(FilerSignature));
  4863. end;
  4864.  
  4865. procedure TWriter.WriteStr(const Value: string);
  4866. var
  4867.   L: Integer;
  4868. begin
  4869.   L := Length(Value);
  4870.   if L > 255 then L := 255;
  4871.   Write(L, SizeOf(Byte));
  4872.   Write(Value[1], L);
  4873. end;
  4874.  
  4875. procedure TWriter.WriteString(const Value: string);
  4876. var
  4877.   L: Integer;
  4878. begin
  4879.   L := Length(Value);
  4880.   if L <= 255 then
  4881.   begin
  4882.     WriteValue(vaString);
  4883.     Write(L, SizeOf(Byte));
  4884.   end else
  4885.   begin
  4886.     WriteValue(vaLString);
  4887.     Write(L, SizeOf(Integer));
  4888.   end;
  4889.   Write(Pointer(Value)^, L);
  4890. end;
  4891.  
  4892. procedure TWriter.WriteValue(Value: TValueType);
  4893. begin
  4894.   Write(Value, SizeOf(Value));
  4895. end;
  4896.  
  4897. { TParser }
  4898.  
  4899. const
  4900.   ParseBufSize = 4096;
  4901.  
  4902. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler;
  4903. asm
  4904.         PUSH    ESI
  4905.         PUSH    EDI
  4906.         MOV     ESI,EAX
  4907.         MOV     EDI,EDX
  4908.         MOV     EDX,0
  4909.         JMP     @@1
  4910. @@0:    DB      '0123456789ABCDEF'
  4911. @@1:    LODSB
  4912.         MOV     DL,AL
  4913.         AND     DL,0FH
  4914.         MOV     AH,@@0.Byte[EDX]
  4915.         MOV     DL,AL
  4916.         SHR     DL,4
  4917.         MOV     AL,@@0.Byte[EDX]
  4918.         STOSW
  4919.         DEC     ECX
  4920.         JNE     @@1
  4921.         POP     EDI
  4922.         POP     ESI
  4923. end;
  4924.  
  4925. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler;
  4926. asm
  4927.         PUSH    ESI
  4928.         PUSH    EDI
  4929.         PUSH    EBX
  4930.         MOV     ESI,EAX
  4931.         MOV     EDI,EDX
  4932.         MOV     EBX,EDX
  4933.         MOV     EDX,0
  4934.         JMP     @@1
  4935. @@0:    DB       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1
  4936.         DB      -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1
  4937.         DB      -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
  4938.         DB      -1,10,11,12,13,14,15
  4939. @@1:    LODSW
  4940.         CMP     AL,'0'
  4941.         JB      @@2
  4942.         CMP     AL,'f'
  4943.         JA      @@2
  4944.         MOV     DL,AL
  4945.         MOV     AL,@@0.Byte[EDX-'0']
  4946.         CMP     AL,-1
  4947.         JE      @@2
  4948.         SHL     AL,4
  4949.         CMP     AH,'0'
  4950.         JB      @@2
  4951.         CMP     AH,'f'
  4952.         JA      @@2
  4953.         MOV     DL,AH
  4954.         MOV     AH,@@0.Byte[EDX-'0']
  4955.         CMP     AH,-1
  4956.         JE      @@2
  4957.         OR      AL,AH
  4958.         STOSB
  4959.         DEC     ECX
  4960.         JNE     @@1
  4961. @@2:    MOV     EAX,EDI
  4962.         SUB     EAX,EBX
  4963.         POP     EBX
  4964.         POP     EDI
  4965.         POP     ESI
  4966. end;
  4967.  
  4968. constructor TParser.Create(Stream: TStream);
  4969. begin
  4970.   FStream := Stream;
  4971.   GetMem(FBuffer, ParseBufSize);
  4972.   FBuffer[0] := #0;
  4973.   FBufPtr := FBuffer;
  4974.   FBufEnd := FBuffer + ParseBufSize;
  4975.   FSourcePtr := FBuffer;
  4976.   FSourceEnd := FBuffer;
  4977.   FTokenPtr := FBuffer;
  4978.   FSourceLine := 1;
  4979.   NextToken;
  4980. end;
  4981.  
  4982. destructor TParser.Destroy;
  4983. begin
  4984.   if FBuffer <> nil then
  4985.   begin
  4986.     FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1);
  4987.     FreeMem(FBuffer, ParseBufSize);
  4988.   end;
  4989. end;
  4990.  
  4991. procedure TParser.CheckToken(T: Char);
  4992. begin
  4993.   if Token <> T then
  4994.     case T of
  4995.       toSymbol:
  4996.         Error(SIdentifierExpected);
  4997.       toString:
  4998.         Error(SStringExpected);
  4999.       toInteger, toFloat:
  5000.         Error(SNumberExpected);
  5001.     else
  5002.       ErrorFmt(SCharExpected, [T]);
  5003.     end;
  5004. end;
  5005.  
  5006. procedure TParser.CheckTokenSymbol(const S: string);
  5007. begin
  5008.   if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]);
  5009. end;
  5010.  
  5011. procedure TParser.Error(const Ident: string);
  5012. begin
  5013.   ErrorStr(Ident);
  5014. end;
  5015.  
  5016. procedure TParser.ErrorFmt(const Ident: string; const Args: array of const);
  5017. begin
  5018.   ErrorStr(Format(Ident, Args));
  5019. end;
  5020.  
  5021. procedure TParser.ErrorStr(const Message: string);
  5022. begin
  5023.   raise EParserError.CreateFmt(SParseError, [Message, FSourceLine]);
  5024. end;
  5025.  
  5026. procedure TParser.HexToBinary(Stream: TStream);
  5027. var
  5028.   Count: Integer;
  5029.   Buffer: array[0..255] of Char;
  5030. begin
  5031.   SkipBlanks;
  5032.   while FSourcePtr^ <> '}' do
  5033.   begin
  5034.     Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer));
  5035.     if Count = 0 then Error(SInvalidBinary);
  5036.     Stream.Write(Buffer, Count);
  5037.     Inc(FSourcePtr, Count * 2);
  5038.     SkipBlanks;
  5039.   end;
  5040.   NextToken;
  5041. end;
  5042.  
  5043. function TParser.NextToken: Char;
  5044. var
  5045.   I: Integer;
  5046.   P, S: PChar;
  5047. begin
  5048.   SkipBlanks;
  5049.   P := FSourcePtr;
  5050.   FTokenPtr := P;
  5051.   case P^ of
  5052.     'A'..'Z', 'a'..'z', '_':
  5053.       begin
  5054.         Inc(P);
  5055.         while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  5056.         Result := toSymbol;
  5057.       end;
  5058.     '#', '''':
  5059.       begin
  5060.         S := P;
  5061.         while True do
  5062.           case P^ of
  5063.             '#':
  5064.               begin
  5065.                 Inc(P);
  5066.                 I := 0;
  5067.                 while P^ in ['0'..'9'] do
  5068.                 begin
  5069.                   I := I * 10 + (Ord(P^) - Ord('0'));
  5070.                   Inc(P);
  5071.                 end;
  5072.                 S^ := Chr(I);
  5073.                 Inc(S);
  5074.               end;
  5075.             '''':
  5076.               begin
  5077.                 Inc(P);
  5078.                 while True do
  5079.                 begin
  5080.                   case P^ of
  5081.                     #0, #10, #13:
  5082.                       Error(SInvalidString);
  5083.                     '''':
  5084.                       begin
  5085.                         Inc(P);
  5086.                         if P^ <> '''' then Break;
  5087.                       end;
  5088.                   end;
  5089.                   S^ := P^;
  5090.                   Inc(S);
  5091.                   Inc(P);
  5092.                 end;
  5093.               end;
  5094.           else
  5095.             Break;
  5096.           end;
  5097.         FStringPtr := S;
  5098.         Result := toString;
  5099.       end;
  5100.     '$':
  5101.       begin
  5102.         Inc(P);
  5103.         while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
  5104.         Result := toInteger;
  5105.       end;
  5106.     '-', '0'..'9':
  5107.       begin
  5108.         Inc(P);
  5109.         while P^ in ['0'..'9'] do Inc(P);
  5110.         Result := toInteger;
  5111.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
  5112.         begin
  5113.           Inc(P);
  5114.           Result := toFloat;
  5115.         end;
  5116.       end;
  5117.   else
  5118.     Result := P^;
  5119.     if Result <> toEOF then Inc(P);
  5120.   end;
  5121.   FSourcePtr := P;
  5122.   FToken := Result;
  5123. end;
  5124.  
  5125. procedure TParser.ReadBuffer;
  5126. var
  5127.   Count: Integer;
  5128. begin
  5129.   Inc(FOrigin, FSourcePtr - FBuffer);
  5130.   FSourceEnd[0] := FSaveChar;
  5131.   Count := FBufPtr - FSourcePtr;
  5132.   if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count);
  5133.   FBufPtr := FBuffer + Count;
  5134.   Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
  5135.   FSourcePtr := FBuffer;
  5136.   FSourceEnd := FBufPtr;
  5137.   if FSourceEnd = FBufEnd then
  5138.   begin
  5139.     FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
  5140.     if FSourceEnd = FBuffer then Error(SLineTooLong);
  5141.   end;
  5142.   FSaveChar := FSourceEnd[0];
  5143.   FSourceEnd[0] := #0;
  5144. end;
  5145.  
  5146. procedure TParser.SkipBlanks;
  5147. begin
  5148.   while True do
  5149.   begin
  5150.     case FSourcePtr^ of
  5151.       #0:
  5152.         begin
  5153.           ReadBuffer;
  5154.           if FSourcePtr^ = #0 then Exit;
  5155.           Continue;
  5156.         end;
  5157.       #10:
  5158.         Inc(FSourceLine);
  5159.       #33..#255:
  5160.         Exit;
  5161.     end;
  5162.     Inc(FSourcePtr);
  5163.   end;
  5164. end;
  5165.  
  5166. function TParser.SourcePos: Longint;
  5167. begin
  5168.   Result := FOrigin + (FTokenPtr - FBuffer);
  5169. end;
  5170.  
  5171. function TParser.TokenFloat: Extended;
  5172. begin
  5173.   Result := StrToFloat(TokenString);
  5174. end;
  5175.  
  5176. function TParser.TokenInt: Longint;
  5177. begin
  5178.   Result := StrToInt(TokenString);
  5179. end;
  5180.  
  5181. function TParser.TokenString: string;
  5182. var
  5183.   L: Integer;
  5184. begin
  5185.   if FToken = toString then
  5186.     L := FStringPtr - FTokenPtr else
  5187.     L := FSourcePtr - FTokenPtr;
  5188.   SetString(Result, FTokenPtr, L);
  5189. end;
  5190.  
  5191. function TParser.TokenSymbolIs(const S: string): Boolean;
  5192. begin
  5193.   Result := (Token = toSymbol) and (CompareText(S, TokenString) = 0);
  5194. end;
  5195.  
  5196. function TParser.TokenComponentIdent: String;
  5197. var
  5198.   P: PChar;
  5199. begin
  5200.   CheckToken(toSymbol);
  5201.   P := FSourcePtr;
  5202.   while P^ = '.' do
  5203.   begin
  5204.     Inc(P);
  5205.     if not (P^ in ['A'..'Z', 'a'..'z', '_']) then
  5206.       Error(SIdentifierExpected);
  5207.     repeat
  5208.       Inc(P)
  5209.     until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  5210.   end;
  5211.   FSourcePtr := P;
  5212.   Result := TokenString;
  5213. end;
  5214.  
  5215. { Binary to text conversion }
  5216.  
  5217. procedure ObjectBinaryToText(Input, Output: TStream);
  5218. var
  5219.   NestingLevel: Integer;
  5220.   SaveSeparator: Char;
  5221.   Reader: TReader;
  5222.   Writer: TWriter;
  5223.  
  5224.   procedure WriteIndent;
  5225.   const
  5226.     Blanks: array[0..1] of Char = '  ';
  5227.   var
  5228.     I: Integer;
  5229.   begin
  5230.     for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
  5231.   end;
  5232.  
  5233.   procedure WriteStr(const S: string);
  5234.   begin
  5235.     Writer.Write(S[1], Length(S));
  5236.   end;
  5237.  
  5238.   procedure NewLine;
  5239.   begin
  5240.     WriteStr(#13#10);
  5241.     WriteIndent;
  5242.   end;
  5243.  
  5244.   procedure ConvertValue; forward;
  5245.  
  5246.   procedure ConvertHeader;
  5247.   var
  5248.     ClassName, ObjectName: string;
  5249.     Flags: TFilerFlags;
  5250.     Position: Integer;
  5251.   begin
  5252.     Reader.ReadPrefix(Flags, Position);
  5253.     ClassName := Reader.ReadStr;
  5254.     ObjectName := Reader.ReadStr;
  5255.     WriteIndent;
  5256.     if ffInherited in Flags then
  5257.       WriteStr('inherited ')
  5258.     else
  5259.       WriteStr('object ');
  5260.     if ObjectName <> '' then
  5261.     begin
  5262.       WriteStr(ObjectName);
  5263.       WriteStr(': ');
  5264.     end;
  5265.     WriteStr(ClassName);
  5266.     if ffChildPos in Flags then
  5267.     begin
  5268.       WriteStr(' [');
  5269.       WriteStr(IntToStr(Position));
  5270.       WriteStr(']');
  5271.     end;
  5272.     WriteStr(#13#10);
  5273.   end;
  5274.  
  5275.   procedure ConvertBinary;
  5276.   const
  5277.     BytesPerLine = 32;
  5278.   var
  5279.     MultiLine: Boolean;
  5280.     I: Integer;
  5281.     Count: Longint;
  5282.     Buffer: array[0..BytesPerLine - 1] of Char;
  5283.     Text: array[0..BytesPerLine * 2 - 1] of Char;
  5284.   begin
  5285.     Reader.ReadValue;
  5286.     WriteStr('{');
  5287.     Inc(NestingLevel);
  5288.     Reader.Read(Count, SizeOf(Count));
  5289.     MultiLine := Count >= BytesPerLine;
  5290.     while Count > 0 do
  5291.     begin
  5292.       if MultiLine then NewLine;
  5293.       if Count >= 32 then I := 32 else I := Count;
  5294.       Reader.Read(Buffer, I);
  5295.       BinToHex(Buffer, Text, I);
  5296.       Writer.Write(Text, I * 2);
  5297.       Dec(Count, I);
  5298.     end;
  5299.     Dec(NestingLevel);
  5300.     WriteStr('}');
  5301.   end;
  5302.  
  5303.   procedure ConvertProperty; forward;
  5304.  
  5305.   procedure ConvertValue;
  5306.   var
  5307.     I, J, L: Integer;
  5308.     S: string;
  5309.   begin
  5310.     case Reader.NextValue of
  5311.       vaList:
  5312.         begin
  5313.           Reader.ReadValue;
  5314.           WriteStr('(');
  5315.           Inc(NestingLevel);
  5316.           while not Reader.EndOfList do
  5317.           begin
  5318.             NewLine;
  5319.             ConvertValue;
  5320.           end;
  5321.           Reader.ReadListEnd;
  5322.           Dec(NestingLevel);
  5323.           WriteStr(')');
  5324.         end;
  5325.       vaInt8, vaInt16, vaInt32:
  5326.         WriteStr(IntToStr(Reader.ReadInteger));
  5327.       vaExtended:
  5328.         WriteStr(FloatToStr(Reader.ReadFloat));
  5329.       vaString, vaLString:
  5330.         begin
  5331.           S := Reader.ReadString;
  5332.           L := Length(S);
  5333.           if L = 0 then WriteStr('''''') else
  5334.           begin
  5335.             I := 1;
  5336.             repeat
  5337.               if (S[I] >= ' ') and (S[I] <> '''') then
  5338.               begin
  5339.                 J := I;
  5340.                 repeat Inc(I) until (I > L) or (S[I] < ' ') or (S[I] = '''');
  5341.                 WriteStr('''');
  5342.                 Writer.Write(S[J], I - J);
  5343.                 WriteStr('''');
  5344.               end else
  5345.               begin
  5346.                 WriteStr('#');
  5347.                 WriteStr(IntToStr(Ord(S[I])));
  5348.                 Inc(I);
  5349.               end;
  5350.             until I > L;
  5351.           end;
  5352.         end;
  5353.       vaIdent, vaFalse, vaTrue, vaNil:
  5354.         WriteStr(Reader.ReadIdent);
  5355.       vaBinary:
  5356.         ConvertBinary;
  5357.       vaSet:
  5358.         begin
  5359.           Reader.ReadValue;
  5360.           WriteStr('[');
  5361.           I := 0;
  5362.           while True do
  5363.           begin
  5364.             S := Reader.ReadStr;
  5365.             if S = '' then Break;
  5366.             if I > 0 then WriteStr(', ');
  5367.             WriteStr(S);
  5368.             Inc(I);
  5369.           end;
  5370.           WriteStr(']');
  5371.         end;
  5372.       vaCollection:
  5373.         begin
  5374.           Reader.ReadValue;
  5375.           WriteStr('<');
  5376.           Inc(NestingLevel);
  5377.           while not Reader.EndOfList do
  5378.           begin
  5379.             NewLine;
  5380.             WriteStr('item');
  5381.             if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
  5382.             begin
  5383.               WriteStr(' [');
  5384.               ConvertValue;
  5385.               WriteStr(']');
  5386.             end;
  5387.             WriteStr(#13#10);
  5388.             Reader.CheckValue(vaList);
  5389.             Inc(NestingLevel);
  5390.             while not Reader.EndOfList do ConvertProperty;
  5391.             Reader.ReadListEnd;
  5392.             Dec(NestingLevel);
  5393.             WriteIndent;
  5394.             WriteStr('end');
  5395.           end;
  5396.           Reader.ReadListEnd;
  5397.           Dec(NestingLevel);
  5398.           WriteStr('>');
  5399.         end;
  5400.     end;
  5401.   end;
  5402.  
  5403.   procedure ConvertProperty;
  5404.   begin
  5405.     WriteIndent;
  5406.     WriteStr(Reader.ReadStr);
  5407.     WriteStr(' = ');
  5408.     ConvertValue;
  5409.     WriteStr(#13#10);
  5410.   end;
  5411.  
  5412.   procedure ConvertObject;
  5413.   begin
  5414.     ConvertHeader;
  5415.     Inc(NestingLevel);
  5416.     while not Reader.EndOfList do ConvertProperty;
  5417.     Reader.ReadListEnd;
  5418.     while not Reader.EndOfList do ConvertObject;
  5419.     Reader.ReadListEnd;
  5420.     Dec(NestingLevel);
  5421.     WriteIndent;
  5422.     WriteStr('end'#13#10);
  5423.   end;
  5424.  
  5425. begin
  5426.   NestingLevel := 0;
  5427.   Reader := TReader.Create(Input, 4096);
  5428.   SaveSeparator := DecimalSeparator;
  5429.   DecimalSeparator := '.';
  5430.   try
  5431.     Writer := TWriter.Create(Output, 4096);
  5432.     try
  5433.       Reader.ReadSignature;
  5434.       ConvertObject;
  5435.     finally
  5436.       Writer.Free;
  5437.     end;
  5438.   finally
  5439.     DecimalSeparator := SaveSeparator;
  5440.     Reader.Free;
  5441.   end;
  5442. end;
  5443.  
  5444.  
  5445. { Text to binary conversion }
  5446.  
  5447. procedure ObjectTextToBinary(Input, Output: TStream);
  5448. var
  5449.   SaveSeparator: Char;
  5450.   Parser: TParser;
  5451.   Writer: TWriter;
  5452.  
  5453.   function ConvertOrderModifier: Integer;
  5454.   begin
  5455.     Result := -1;
  5456.     if Parser.Token = '[' then
  5457.     begin
  5458.       Parser.NextToken;
  5459.       Parser.CheckToken(toInteger);
  5460.       Result := Parser.TokenInt;
  5461.       Parser.NextToken;
  5462.       Parser.CheckToken(']');
  5463.       Parser.NextToken;
  5464.     end;
  5465.   end;
  5466.  
  5467.   procedure ConvertHeader(IsInherited: Boolean);
  5468.   var
  5469.     ClassName, ObjectName: string;
  5470.     Flags: TFilerFlags;
  5471.     Position: Integer;
  5472.   begin
  5473.     Parser.CheckToken(toSymbol);
  5474.     ClassName := Parser.TokenString;
  5475.     ObjectName := '';
  5476.     if Parser.NextToken = ':' then
  5477.     begin
  5478.       Parser.NextToken;
  5479.       Parser.CheckToken(toSymbol);
  5480.       ObjectName := ClassName;
  5481.       ClassName := Parser.TokenString;
  5482.       Parser.NextToken;
  5483.     end;
  5484.     Flags := [];
  5485.     Position := ConvertOrderModifier;
  5486.     if IsInherited then
  5487.       Include(Flags, ffInherited);
  5488.     if Position > 0 then
  5489.       Include(Flags, ffChildPos);
  5490.     Writer.WritePrefix(Flags, Position);
  5491.     Writer.WriteStr(ClassName);
  5492.     Writer.WriteStr(ObjectName);
  5493.   end;
  5494.  
  5495.   procedure ConvertProperty; forward;
  5496.  
  5497.   procedure ConvertValue;
  5498.   var
  5499.     Order: Integer;
  5500.   begin
  5501.     case Parser.Token of
  5502.       toSymbol:
  5503.         Writer.WriteIdent(Parser.TokenComponentIdent);
  5504.       toString:
  5505.         Writer.WriteString(Parser.TokenString);
  5506.       toInteger:
  5507.         Writer.WriteInteger(Parser.TokenInt);
  5508.       toFloat:
  5509.         Writer.WriteFloat(Parser.TokenFloat);
  5510.       '[':
  5511.         begin
  5512.           Parser.NextToken;
  5513.           Writer.WriteValue(vaSet);
  5514.           if Parser.Token <> ']' then
  5515.             while True do
  5516.             begin
  5517.               Parser.CheckToken(toSymbol);
  5518.               Writer.WriteStr(Parser.TokenString);
  5519.               if Parser.NextToken = ']' then Break;
  5520.               Parser.CheckToken(',');
  5521.               Parser.NextToken;
  5522.             end;
  5523.           Writer.WriteStr('');
  5524.         end;
  5525.       '(':
  5526.         begin
  5527.           Parser.NextToken;
  5528.           Writer.WriteListBegin;
  5529.           while Parser.Token <> ')' do ConvertValue;
  5530.           Writer.WriteListEnd;
  5531.         end;
  5532.       '{':
  5533.         Writer.WriteBinary(Parser.HexToBinary);
  5534.       '<':
  5535.         begin
  5536.           Parser.NextToken;
  5537.           Writer.WriteValue(vaCollection);
  5538.           while Parser.Token <> '>' do
  5539.           begin
  5540.             Parser.CheckTokenSymbol('item');
  5541.             Parser.NextToken;
  5542.             Order := ConvertOrderModifier;
  5543.             if Order <> -1 then Writer.WriteInteger(Order);
  5544.             Writer.WriteListBegin;
  5545.             while not Parser.TokenSymbolIs('end') do ConvertProperty;
  5546.             Writer.WriteListEnd;
  5547.             Parser.NextToken;
  5548.           end;
  5549.           Writer.WriteListEnd;
  5550.         end;
  5551.     else
  5552.       Parser.Error(SInvalidProperty);
  5553.     end;
  5554.     Parser.NextToken;
  5555.   end;
  5556.  
  5557.   procedure ConvertProperty;
  5558.   var
  5559.     PropName: string;
  5560.   begin
  5561.     Parser.CheckToken(toSymbol);
  5562.     PropName := Parser.TokenString;
  5563.     Parser.NextToken;
  5564.     while Parser.Token = '.' do
  5565.     begin
  5566.       Parser.NextToken;
  5567.       Parser.CheckToken(toSymbol);
  5568.       PropName := PropName + '.' + Parser.TokenString;
  5569.       Parser.NextToken;
  5570.     end;
  5571.     Writer.WriteStr(PropName);
  5572.     Parser.CheckToken('=');
  5573.     Parser.NextToken;
  5574.     ConvertValue;
  5575.   end;
  5576.  
  5577.   procedure ConvertObject;
  5578.   var
  5579.     InheritedObject: Boolean;
  5580.   begin
  5581.     InheritedObject := False;
  5582.     if Parser.TokenSymbolIs('INHERITED') then
  5583.       InheritedObject := True else
  5584.       Parser.CheckTokenSymbol('OBJECT');
  5585.     Parser.NextToken;
  5586.     ConvertHeader(InheritedObject);
  5587.     while not Parser.TokenSymbolIs('END') and
  5588.       not Parser.TokenSymbolIs('OBJECT') and
  5589.       not Parser.TokenSymbolIs('INHERITED') do ConvertProperty;
  5590.     Writer.WriteListEnd;
  5591.     while not Parser.TokenSymbolIs('END') do ConvertObject;
  5592.     Writer.WriteListEnd;
  5593.     Parser.NextToken;
  5594.   end;
  5595.  
  5596. begin
  5597.   Parser := TParser.Create(Input);
  5598.   SaveSeparator := DecimalSeparator;
  5599.   DecimalSeparator := '.';
  5600.   try
  5601.     Writer := TWriter.Create(Output, 4096);
  5602.     try
  5603.       Writer.WriteSignature;
  5604.       ConvertObject;
  5605.     finally
  5606.       Writer.Free;
  5607.     end;
  5608.   finally
  5609.     DecimalSeparator := SaveSeparator;
  5610.     Parser.Free;
  5611.   end;
  5612. end;
  5613.  
  5614. { Resource to text conversion }
  5615.  
  5616. procedure ObjectResourceToText(Input, Output: TStream);
  5617. begin
  5618.   Input.ReadResHeader;
  5619.   ObjectBinaryToText(Input, Output);
  5620. end;
  5621.  
  5622. { Text to resource conversion }
  5623.  
  5624. procedure ObjectTextToResource(Input, Output: TStream);
  5625. var
  5626.   Len: Byte;
  5627.   Tmp: Longint;
  5628.   MemoryStream: TMemoryStream;
  5629.   MemorySize: Longint;
  5630.   Header: array[0..79] of Char;
  5631. begin
  5632.   MemoryStream := TMemoryStream.Create;
  5633.   try
  5634.     ObjectTextToBinary(Input, MemoryStream);
  5635.     MemorySize := MemoryStream.Size;
  5636.     FillChar(Header, SizeOf(Header), 0);
  5637.     MemoryStream.Position := SizeOf(Longint); { Skip header }
  5638.     MemoryStream.Read(Len, 1);
  5639.  
  5640.     { Skip over object prefix if it is present }
  5641.     if Len and $F0 = $F0 then
  5642.     begin
  5643.       if ffChildPos in TFilerFlags((Len and $F0)) then
  5644.       begin
  5645.         MemoryStream.Read(Len, 1);
  5646.         case TValueType(Len) of
  5647.           vaInt8: Len := 1;
  5648.           vaInt16: Len := 2;
  5649.           vaInt32: Len := 4;
  5650.         end;
  5651.         MemoryStream.Read(Tmp, Len);
  5652.       end;
  5653.       MemoryStream.Read(Len, 1);
  5654.     end;
  5655.  
  5656.     MemoryStream.Read(Header[3], Len);
  5657.     StrUpper(@Header[3]);
  5658.     Byte((@Header[0])^) := $FF;
  5659.     Word((@Header[1])^) := 10;
  5660.     Word((@Header[Len + 4])^) := $1030;
  5661.     Longint((@Header[Len + 6])^) := MemorySize;
  5662.     Output.Write(Header, Len + 10);
  5663.     Output.Write(MemoryStream.Memory^, MemorySize);
  5664.   finally
  5665.     MemoryStream.Free;
  5666.   end;
  5667. end;
  5668.  
  5669. { Thread management routines }
  5670.  
  5671. const
  5672.   CM_EXECPROC = $8FFF;
  5673.  
  5674. type
  5675.   PRaiseFrame = ^TRaiseFrame;
  5676.   TRaiseFrame = record
  5677.     NextRaise: PRaiseFrame;
  5678.     ExceptAddr: Pointer;
  5679.     ExceptObject: TObject;
  5680.     ExceptionRecord: PExceptionRecord;
  5681.   end;
  5682.  
  5683. var
  5684.   ThreadWindow: HWND;
  5685.   ThreadCount: Integer;
  5686.  
  5687. function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
  5688. begin
  5689.   case Message of
  5690.     CM_EXECPROC:
  5691.       with TThread(lParam) do
  5692.       begin
  5693.         Result := 0;
  5694.         try
  5695.           FSynchronizeException := nil;
  5696.           FMethod;
  5697.         except
  5698.           if RaiseList <> nil then
  5699.           begin
  5700.             FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
  5701.             PRaiseFrame(RaiseList)^.ExceptObject := nil;
  5702.           end;
  5703.         end;
  5704.       end;
  5705.   else
  5706.     Result := DefWindowProc(Window, Message, wParam, lParam);
  5707.   end;
  5708. end;
  5709.  
  5710. var
  5711.   ThreadWindowClass: TWndClass = (
  5712.     style: 0;
  5713.     lpfnWndProc: @ThreadWndProc;
  5714.     cbClsExtra: 0;
  5715.     cbWndExtra: 0;
  5716.     hInstance: 0;
  5717.     hIcon: 0;
  5718.     hCursor: 0;
  5719.     hbrBackground: 0;
  5720.     lpszMenuName: nil;
  5721.     lpszClassName: 'TThreadWindow');
  5722.  
  5723. procedure AddThread;
  5724.  
  5725.   function AllocateWindow: HWND;
  5726.   var
  5727.     TempClass: TWndClass;
  5728.     ClassRegistered: Boolean;
  5729.   begin
  5730.     ThreadWindowClass.hInstance := HInstance;
  5731.     ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
  5732.       TempClass);
  5733.     if not ClassRegistered or (TempClass.lpfnWndProc <> @ThreadWndProc) then
  5734.     begin
  5735.       if ClassRegistered then
  5736.         Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
  5737.       Windows.RegisterClass(ThreadWindowClass);
  5738.     end;
  5739.     Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
  5740.       0, 0, 0, 0, 0, 0, HInstance, nil);
  5741.   end;
  5742.  
  5743. begin
  5744.   if ThreadCount = 0 then
  5745.     ThreadWindow := AllocateWindow;
  5746.   Inc(ThreadCount);
  5747. end;
  5748.  
  5749. procedure RemoveThread;
  5750. begin
  5751.   Dec(ThreadCount);
  5752.   if ThreadCount = 0 then DestroyWindow(ThreadWindow);
  5753. end;
  5754.  
  5755. { TThread }
  5756.  
  5757. function ThreadProc(Thread: TThread): Integer;
  5758. var
  5759.   FreeThread: Boolean;
  5760. begin
  5761.   Thread.Execute;
  5762.   FreeThread := Thread.FFreeOnTerminate;
  5763.   Result := Thread.FReturnValue;
  5764.   Thread.FFinished := True;
  5765.   Thread.DoTerminate;
  5766.   if FreeThread then Thread.Free;
  5767.   EndThread(Result);
  5768. end;
  5769.  
  5770. constructor TThread.Create(CreateSuspended: Boolean);
  5771. var
  5772.   Flags: Integer;
  5773. begin
  5774.   inherited Create;
  5775.   AddThread;
  5776.   FSuspended := CreateSuspended;
  5777.   Flags := 0;
  5778.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  5779.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  5780. end;
  5781.  
  5782. destructor TThread.Destroy;
  5783. begin
  5784.   if not FFinished and not Suspended then
  5785.   begin
  5786.     Terminate;
  5787.     WaitFor;
  5788.   end;
  5789.   if FHandle <> 0 then CloseHandle(FHandle);
  5790.   inherited Destroy;
  5791.   RemoveThread;
  5792. end;
  5793.  
  5794. procedure TThread.CallOnTerminate;
  5795. begin
  5796.   FOnTerminate(Self);
  5797. end;
  5798.  
  5799. procedure TThread.DoTerminate;
  5800. begin
  5801.   if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
  5802. end;
  5803.  
  5804. const
  5805.   Priorities: array [TThreadPriority] of Integer =
  5806.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  5807.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  5808.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  5809.  
  5810. function TThread.GetPriority: TThreadPriority;
  5811. var
  5812.   P: Integer;
  5813.   I: TThreadPriority;
  5814. begin
  5815.   P := GetThreadPriority(FHandle);
  5816.   Result := tpNormal;
  5817.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  5818.     if Priorities[I] = P then Result := I;
  5819. end;
  5820.  
  5821. procedure TThread.SetPriority(Value: TThreadPriority);
  5822. begin
  5823.   SetThreadPriority(FHandle, Priorities[Value]);
  5824. end;
  5825.  
  5826. procedure TThread.Synchronize(Method: TThreadMethod);
  5827. begin
  5828.   FSynchronizeException := nil;
  5829.   FMethod := Method;
  5830.   SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
  5831.   if Assigned(FSynchronizeException) then raise FSynchronizeException;
  5832. end;
  5833.  
  5834. procedure TThread.SetSuspended(Value: Boolean);
  5835. begin
  5836.   if Value <> FSuspended then
  5837.     if Value then
  5838.       Suspend else
  5839.       Resume;
  5840. end;
  5841.  
  5842. procedure TThread.Suspend;
  5843. begin
  5844.   FSuspended := True;
  5845.   SuspendThread(FHandle);
  5846. end;
  5847.  
  5848. procedure TThread.Resume;
  5849. begin
  5850.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  5851. end;
  5852.  
  5853. procedure TThread.Terminate;
  5854. begin
  5855.   FTerminated := True;
  5856. end;
  5857.  
  5858. function TThread.WaitFor: Integer;
  5859. var
  5860.   Msg: TMsg;
  5861. begin
  5862.   if GetCurrentThreadID = MainThreadID then
  5863.     while MsgWaitForMultipleObjects(1, FHandle, False, INFINITE,
  5864.       QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
  5865.   else WaitForSingleObject(FHandle, INFINITE);
  5866.   GetExitCodeThread(FHandle, Result);
  5867. end;
  5868.  
  5869. { TComponent }
  5870.  
  5871. constructor TComponent.Create(AOwner: TComponent);
  5872. begin
  5873.   FComponentStyle := [csInheritable];
  5874.   if AOwner <> nil then AOwner.InsertComponent(Self);
  5875. end;
  5876.  
  5877. destructor TComponent.Destroy;
  5878. var
  5879.   I: Integer;
  5880. begin
  5881.   if FFreeNotifies <> nil then
  5882.   begin
  5883.     for I := 0 to FFreeNotifies.Count - 1 do
  5884.       TComponent(FFreeNotifies[I]).Notification(Self, opRemove);
  5885.     FFreeNotifies.Free;
  5886.     FFreeNotifies := nil;
  5887.   end;
  5888.   Destroying;
  5889.   DestroyComponents;
  5890.   if FOwner <> nil then FOwner.RemoveComponent(Self);
  5891. end;
  5892.  
  5893. procedure TComponent.FreeNotification(AComponent: TComponent);
  5894. begin
  5895.   if (Owner = nil) or (AComponent.Owner <> Owner) then
  5896.   begin
  5897.     if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create;
  5898.     if FFreeNotifies.IndexOf(AComponent) < 0 then
  5899.     begin
  5900.       FFreeNotifies.Add(AComponent);
  5901.       AComponent.FreeNotification(Self);
  5902.     end;
  5903.   end;
  5904. end;
  5905.  
  5906. procedure TComponent.ReadLeft(Reader: TReader);
  5907. begin
  5908.   LongRec(FDesignInfo).Lo := Reader.ReadInteger;
  5909. end;
  5910.  
  5911. procedure TComponent.ReadTop(Reader: TReader);
  5912. begin
  5913.   LongRec(FDesignInfo).Hi := Reader.ReadInteger;
  5914. end;
  5915.  
  5916. procedure TComponent.WriteLeft(Writer: TWriter);
  5917. begin
  5918.   Writer.WriteInteger(LongRec(FDesignInfo).Lo);
  5919. end;
  5920.  
  5921. procedure TComponent.WriteTop(Writer: TWriter);
  5922. begin
  5923.   Writer.WriteInteger(LongRec(FDesignInfo).Hi);
  5924. end;
  5925.  
  5926. procedure TComponent.Insert(AComponent: TComponent);
  5927. begin
  5928.   if FComponents = nil then FComponents := TList.Create;
  5929.   FComponents.Add(AComponent);
  5930.   AComponent.FOwner := Self;
  5931. end;
  5932.  
  5933. procedure TComponent.Remove(AComponent: TComponent);
  5934. begin
  5935.   AComponent.FOwner := nil;
  5936.   FComponents.Remove(AComponent);
  5937.   if FComponents.Count = 0 then
  5938.   begin
  5939.     FComponents.Free;
  5940.     FComponents := nil;
  5941.   end;
  5942. end;
  5943.  
  5944. procedure TComponent.InsertComponent(AComponent: TComponent);
  5945. begin
  5946.   AComponent.ValidateContainer(Self);
  5947.   ValidateRename(AComponent, '', AComponent.FName);
  5948.   Insert(AComponent);
  5949.   AComponent.SetReference(True);
  5950.   if csDesigning in ComponentState then
  5951.     AComponent.SetDesigning(True);
  5952.   Notification(AComponent, opInsert);
  5953. end;
  5954.  
  5955. procedure TComponent.RemoveComponent(AComponent: TComponent);
  5956. begin
  5957.   Notification(AComponent, opRemove);
  5958.   AComponent.SetReference(False);
  5959.   Remove(AComponent);
  5960.   AComponent.SetDesigning(False);
  5961.   ValidateRename(AComponent, AComponent.FName, '');
  5962. end;
  5963.  
  5964. procedure TComponent.DestroyComponents;
  5965. var
  5966.   Instance: TComponent;
  5967. begin
  5968.   while FComponents <> nil do
  5969.   begin
  5970.     Instance := FComponents.Last;
  5971.     Remove(Instance);
  5972.     Instance.Destroy;
  5973.   end;
  5974. end;
  5975.  
  5976. procedure TComponent.Destroying;
  5977. var
  5978.   I: Integer;
  5979. begin
  5980.   if not (csDestroying in FComponentState) then
  5981.   begin
  5982.     Include(FComponentState, csDestroying);
  5983.     if FComponents <> nil then
  5984.       for I := 0 to FComponents.Count - 1 do
  5985.         TComponent(FComponents[I]).Destroying;
  5986.   end;
  5987. end;
  5988.  
  5989. procedure TComponent.Notification(AComponent: TComponent;
  5990.   Operation: TOperation);
  5991. var
  5992.   I: Integer;
  5993. begin
  5994.   if (FFreeNotifies <> nil) and (Operation = opRemove) then
  5995.   begin
  5996.     FFreeNotifies.Remove(AComponent);
  5997.     if FFreeNotifies.Count = 0 then
  5998.     begin
  5999.       FFreeNotifies.Free;
  6000.       FFreeNotifies := nil;
  6001.     end;
  6002.   end;
  6003.   if FComponents <> nil then
  6004.     for I := 0 to FComponents.Count - 1 do
  6005.       TComponent(FComponents[I]).Notification(AComponent, Operation);
  6006. end;
  6007.  
  6008. procedure TComponent.DefineProperties(Filer: TFiler);
  6009. var
  6010.   Ancestor: TComponent;
  6011.   Info: Longint;
  6012. begin
  6013.   Info := 0;
  6014.   Ancestor := TComponent(Filer.Ancestor);
  6015.   if Ancestor <> nil then Info := Ancestor.FDesignInfo;
  6016.   Filer.DefineProperty('Left', ReadLeft, WriteLeft,
  6017.     LongRec(FDesignInfo).Lo <> LongRec(Info).Lo);
  6018.   Filer.DefineProperty('Top', ReadTop, WriteTop,
  6019.     LongRec(FDesignInfo).Hi <> LongRec(Info).Hi);
  6020. end;
  6021.  
  6022. function TComponent.HasParent: Boolean;
  6023. begin
  6024.   Result := False;
  6025. end;
  6026.  
  6027. procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
  6028. begin
  6029. end;
  6030.  
  6031. function TComponent.GetChildOwner: TComponent;
  6032. begin
  6033.   Result := nil;
  6034. end;
  6035.  
  6036. function TComponent.GetChildParent: TComponent;
  6037. begin
  6038.   Result := Self;
  6039. end;
  6040.  
  6041. function TComponent.GetNamePath: string;
  6042. begin
  6043.   Result := FName;
  6044. end;
  6045.  
  6046. function TComponent.GetOwner: TPersistent;
  6047. begin
  6048.   Result := FOwner;
  6049. end;
  6050.  
  6051. procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer);
  6052. begin
  6053. end;
  6054.  
  6055. function TComponent.GetParentComponent: TComponent;
  6056. begin
  6057.   Result := nil;
  6058. end;
  6059.  
  6060. procedure TComponent.SetParentComponent(Value: TComponent);
  6061. begin
  6062. end;
  6063.  
  6064. procedure TComponent.Updating;
  6065. begin
  6066.   Include(FComponentState, csUpdating);
  6067. end;
  6068.  
  6069. procedure TComponent.Updated;
  6070. begin
  6071.   Exclude(FComponentState, csUpdating);
  6072. end;
  6073.  
  6074. procedure TComponent.Loaded;
  6075. begin
  6076.   Exclude(FComponentState, csLoading);
  6077. end;
  6078.  
  6079. procedure TComponent.ReadState(Reader: TReader);
  6080. begin
  6081.   Reader.ReadData(Self);
  6082. end;
  6083.  
  6084. procedure TComponent.WriteState(Writer: TWriter);
  6085. begin
  6086.   Writer.WriteData(Self);
  6087. end;
  6088.  
  6089. procedure TComponent.ValidateRename(AComponent: TComponent;
  6090.   const CurName, NewName: string);
  6091. begin
  6092.   if (AComponent <> nil) and (CompareText(CurName, NewName) <> 0) and
  6093.     (FindComponent(NewName) <> nil) then
  6094.     raise EComponentError.CreateFmt(SDuplicateName, [NewName]);
  6095.   if (csDesigning in ComponentState) and (Owner <> nil) then
  6096.     Owner.ValidateRename(AComponent, CurName, NewName);
  6097. end;
  6098.  
  6099. procedure TComponent.ValidateContainer(AComponent: TComponent);
  6100. begin
  6101.   AComponent.ValidateInsert(Self);
  6102. end;
  6103.  
  6104. procedure TComponent.ValidateInsert(AComponent: TComponent);
  6105. begin
  6106. end;
  6107.  
  6108. function TComponent.FindComponent(const AName: string): TComponent;
  6109. var
  6110.   I: Integer;
  6111. begin
  6112.   if (AName <> '') and (FComponents <> nil) then
  6113.     for I := 0 to FComponents.Count - 1 do
  6114.     begin
  6115.       Result := FComponents[I];
  6116.       if CompareText(Result.FName, AName) = 0 then Exit;
  6117.     end;
  6118.   Result := nil;
  6119. end;
  6120.  
  6121. procedure TComponent.SetName(const NewName: TComponentName);
  6122. begin
  6123.   if FName <> NewName then
  6124.   begin
  6125.     if (NewName <> '') and not IsValidIdent(NewName) then
  6126.       raise EComponentError.CreateFmt(SInvalidName, [NewName]);
  6127.     if FOwner <> nil then
  6128.       FOwner.ValidateRename(Self, FName, NewName) else
  6129.       ValidateRename(nil, FName, NewName);
  6130.     SetReference(False);
  6131.     ChangeName(NewName);
  6132.     SetReference(True);
  6133.   end;
  6134. end;
  6135.  
  6136. procedure TComponent.ChangeName(const NewName: TComponentName);
  6137. begin
  6138.   FName := NewName;
  6139. end;
  6140.  
  6141. function TComponent.GetComponentIndex: Integer;
  6142. begin
  6143.   if (FOwner <> nil) and (FOwner.FComponents <> nil) then
  6144.     Result := FOwner.FComponents.IndexOf(Self) else
  6145.     Result := -1;
  6146. end;
  6147.  
  6148. function TComponent.GetComponent(AIndex: Integer): TComponent;
  6149. begin
  6150.   if FComponents = nil then TList.Error(SListIndexError, AIndex);
  6151.   Result := FComponents[AIndex];
  6152. end;
  6153.  
  6154. function TComponent.GetComponentCount: Integer;
  6155. begin
  6156.   if FComponents <> nil then
  6157.     Result := FComponents.Count else
  6158.     Result := 0;
  6159. end;
  6160.  
  6161. procedure TComponent.SetComponentIndex(Value: Integer);
  6162. var
  6163.   I, Count: Integer;
  6164. begin
  6165.   if FOwner <> nil then
  6166.   begin
  6167.     I := FOwner.FComponents.IndexOf(Self);
  6168.     if I >= 0 then
  6169.     begin
  6170.       Count := FOwner.FComponents.Count;
  6171.       if Value < 0 then Value := 0;
  6172.       if Value >= Count then Value := Count - 1;
  6173.       if Value <> I then
  6174.       begin
  6175.         FOwner.FComponents.Delete(I);
  6176.         FOwner.FComponents.Insert(Value, Self);
  6177.       end;
  6178.     end;
  6179.   end;
  6180. end;
  6181.  
  6182. procedure TComponent.SetAncestor(Value: Boolean);
  6183. var
  6184.   I: Integer;
  6185. begin
  6186.   if Value then
  6187.     Include(FComponentState, csAncestor) else
  6188.     Exclude(FComponentState, csAncestor);
  6189.   for I := 0 to ComponentCount - 1 do
  6190.     Components[I].SetAncestor(Value);
  6191. end;
  6192.  
  6193. procedure TComponent.SetDesigning(Value: Boolean);
  6194. var
  6195.   I: Integer;
  6196. begin
  6197.   if Value then
  6198.     Include(FComponentState, csDesigning) else
  6199.     Exclude(FComponentState, csDesigning);
  6200.   for I := 0 to ComponentCount - 1 do Components[I].SetDesigning(Value);
  6201. end;
  6202.  
  6203. procedure TComponent.SetReference(Enable: Boolean);
  6204. var
  6205.   Field: ^TComponent;
  6206. begin
  6207.   if FOwner <> nil then
  6208.   begin
  6209.     Field := FOwner.FieldAddress(FName);
  6210.     if Field <> nil then
  6211.       if Enable then Field^ := Self else Field^ := nil;
  6212.   end;
  6213. end;
  6214.  
  6215. function TComponent.GetComObject: IUnknown;
  6216. begin
  6217.   if FVCLComObject = nil then
  6218.   begin
  6219.     if Assigned(CreateVCLComObjectProc) then CreateVCLComObjectProc(Self);
  6220.     if FVCLComObject = nil then
  6221.       raise EComponentError.CreateFmt(SNoComSupport, [ClassName]);
  6222.   end;
  6223.   IVCLComObject(FVCLComObject).QueryInterface(IUnknown, Result);
  6224. end;
  6225.  
  6226. function TComponent.SafeCallException(ExceptObject: TObject;
  6227.   ExceptAddr: Pointer): Integer;
  6228. begin
  6229.   if FVCLComObject <> nil then
  6230.     Result := IVCLComObject(FVCLComObject).SafeCallException(
  6231.       ExceptObject, ExceptAddr)
  6232.   else
  6233.     Result := inherited SafeCallException(ExceptObject, ExceptAddr);
  6234. end;
  6235.  
  6236. procedure TComponent.FreeOnRelease;
  6237. begin
  6238.   if FVCLComObject <> nil then IVCLComObject(FVCLComObject).FreeOnRelease;
  6239. end;
  6240.  
  6241. { TComponent.IUnknown }
  6242.  
  6243. function TComponent.QueryInterface(const IID: TGUID; out Obj): Integer;
  6244. begin
  6245.   Result := IVCLComObject(FVCLComObject).QueryInterface(IID, Obj);
  6246. end;
  6247.  
  6248. function TComponent._AddRef: Integer;
  6249. begin
  6250.   Result := IVCLComObject(FVCLComObject)._AddRef;
  6251. end;
  6252.  
  6253. function TComponent._Release: Integer;
  6254. begin
  6255.   Result := IVCLComObject(FVCLComObject)._Release;
  6256. end;
  6257.  
  6258. { TComponent.IDispatch }
  6259.  
  6260. function TComponent.GetTypeInfoCount(out Count: Integer): Integer;
  6261. begin
  6262.   Result := IVCLComObject(FVCLComObject).GetTypeInfoCount(Count);
  6263. end;
  6264.  
  6265. function TComponent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer;
  6266. begin
  6267.   Result := IVCLComObject(FVCLComObject).GetTypeInfo(
  6268.     Index, LocaleID, TypeInfo);
  6269. end;
  6270.  
  6271. function TComponent.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  6272.   NameCount, LocaleID: Integer; DispIDs: Pointer): Integer;
  6273. begin
  6274.   Result := IVCLComObject(FVCLComObject).GetIDsOfNames(IID, Names,
  6275.     NameCount, LocaleID, DispIDs);
  6276. end;
  6277.  
  6278. function TComponent.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  6279.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer;
  6280. begin
  6281.   Result := IVCLComObject(FVCLComObject).Invoke(DispID, IID, LocaleID,
  6282.     Flags, Params, VarResult, ExcepInfo, ArgErr);
  6283. end;
  6284.  
  6285. procedure FreeIntConstList;
  6286. var
  6287.   I: Integer;
  6288. begin
  6289.   for I := 0 to IntConstList.Count - 1 do
  6290.     TIntConst(IntConstList[I]).Free;
  6291.   IntConstList.Free;
  6292. end;
  6293.  
  6294. procedure ModuleUnload(Instance: Longint);
  6295. begin
  6296.   UnregisterModuleClasses(HMODULE(Instance));
  6297. end;
  6298.  
  6299. initialization
  6300.   AddModuleUnloadProc(ModuleUnload);
  6301.   ClassList := TList.Create;
  6302.   ClassAliasList := TStringList.Create;
  6303.   IntConstList := TList.Create;
  6304.   GlobalFixupList := TList.Create;
  6305.   MainThreadID := GetCurrentThreadID;
  6306.   GlobalLists := TList.Create;
  6307.  
  6308. finalization
  6309.   UnRegisterModuleClasses(HInstance);
  6310.   ClassList.Free;
  6311.   ClassAliasList.Free;
  6312.   FreeIntConstList;
  6313.   RemoveFixupReferences(nil, '');
  6314.   GlobalFixupList.Free;
  6315.   GlobalLists.Free;
  6316.   RemoveModuleUnloadProc(ModuleUnload);
  6317.  
  6318. end.
  6319.